From: Kevin M. Rosenberg Date: Tue, 17 Sep 2002 17:16:43 +0000 (+0000) Subject: r2741: Start migration to pathname-less asd files, remove .system files X-Git-Tag: v3.8.6~949 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=31d1a78ee915ae4db7c042b7e5cb1ab7b5a73448 r2741: Start migration to pathname-less asd files, remove .system files --- diff --git a/base/.cvsignore b/base/.cvsignore new file mode 100644 index 0000000..ca8d09f --- /dev/null +++ b/base/.cvsignore @@ -0,0 +1 @@ +.bin diff --git a/base/Makefile b/base/Makefile new file mode 100644 index 0000000..31dc910 --- /dev/null +++ b/base/Makefile @@ -0,0 +1,6 @@ +SUBDIRS := + +include ../Makefile.common + +.PHONY: distclean +distclean: clean diff --git a/base/classes.cl b/base/classes.cl new file mode 100644 index 0000000..26dbf71 --- /dev/null +++ b/base/classes.cl @@ -0,0 +1,55 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: classes.cl +;;;; Purpose: Classes for High-level SQL interface +;;;; Programmers: Kevin M. Rosenberg based on +;;;; original code by Pierre R. Mai +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: classes.cl,v 1.4 2002/09/17 17:16:43 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 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. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :clsql-base-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") + (transaction-level :initform 0 :accessor transaction-level) + (transaction :initform nil :accessor transaction) + (conn-pool :initform nil :initarg :conn-pool :accessor conn-pool)) + (: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) + (write-string (if (slot-boundp object 'name) + (database-name object) + "") + stream))) + +;; Closed database idea and original code comes from UncommonSQL + +(defclass closed-database () + ((name :initarg :name :reader database-name)) + (:documentation + "This class represents databases after they are closed via 'disconnect'.")) + +(defmethod print-object ((object closed-database) stream) + (print-unreadable-object (object stream :type t :identity t) + (write-string (if (slot-boundp object 'name) + (database-name object) + "") + stream))) + diff --git a/base/cmucl-compat.cl b/base/cmucl-compat.cl new file mode 100644 index 0000000..4f65794 --- /dev/null +++ b/base/cmucl-compat.cl @@ -0,0 +1,115 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: cmucl-compat.sql +;;;; Purpose: Compatiblity library for CMUCL functions +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: cmucl-compat.cl,v 1.3 2002/09/17 17:16:43 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :cl-user) + +(defpackage :cmucl-compat + (:export + #:shrink-vector + #:make-sequence-of-type + #:result-type-or-lose + #:required-argument + )) +(in-package :cmucl-compat) + +#+cmu +(defmacro required-argument () + `(ext:required-argument)) + +#-cmu +(defun required-argument () + (error "~&A required keyword argument was not supplied")) + +#+cmu +(defmacro shrink-vector (vec len) + `(lisp::shrink-vector ,vec ,len)) + +#-cmu +(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)))) + (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))) + ))) + + + +#-cmu +(defun make-sequence-of-type (type length) + "Returns a sequence of the given TYPE and LENGTH." + (declare (fixnum length)) + (case type + (list + (make-list length)) + ((bit-vector simple-bit-vector) + (make-array length :element-type '(mod 2))) + ((string simple-string base-string simple-base-string) + (make-string length)) + (simple-vector + (make-array length)) + ((array simple-array vector) + (if (listp type) + (make-array length :element-type (cadr type)) + (make-array length))) + (t + (make-sequence-of-type (result-type-or-lose type t) length)))) + + +#+cmu +(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) + (system::make-sequence-of-type type len))) + + +#-cmu +(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)) + )) + +#+cmu +(defun result-type-or-lose (type nil-ok) + (lisp::result-type-or-lose type nil-ok)) diff --git a/base/conditions.cl b/base/conditions.cl new file mode 100644 index 0000000..c713f20 --- /dev/null +++ b/base/conditions.cl @@ -0,0 +1,160 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: conditions.cl +;;;; 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: conditions.cl,v 1.4 2002/09/17 17:16:43 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 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. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :clsql-base-sys) + +;;; 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-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 ,@template)) + t) + (error () (error 'clsql-invalid-spec-error + :connection-spec ,connection-spec + :database-type ,database-type + :template (quote ,template))))) + +(define-condition clsql-connect-error (clsql-error) + ((database-type :initarg :database-type + :reader clsql-connect-error-database-type) + (connection-spec :initarg :connection-spec + :reader clsql-connect-error-connection-spec) + (errno :initarg :errno :reader clsql-connect-error-errno) + (error :initarg :error :reader clsql-connect-error-error)) + (: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-connect-error-connection-spec c) + (clsql-connect-error-database-type c)) + (clsql-connect-error-database-type c) + (clsql-connect-error-errno c) + (clsql-connect-error-error c))))) + +(define-condition clsql-sql-error (clsql-error) + ((database :initarg :database :reader clsql-sql-error-database) + (expression :initarg :expression :reader clsql-sql-error-expression) + (errno :initarg :errno :reader clsql-sql-error-errno) + (error :initarg :error :reader clsql-sql-error-error)) + (:report (lambda (c stream) + (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-nodb-error (clsql-error) + ((database :initarg :database :reader clsql-nodb-error-database)) + (:report (lambda (c stream) + (format stream "No such database ~S is open." + (clsql-nodb-error-database c))))) + + +;; Signal conditions + + +(defun signal-closed-database-error (database) + (cerror "Ignore this error and return nil." + 'clsql-closed-error + :database database)) + +(defun signal-nodb-error (database) + (cerror "Ignore this error and return nil." + 'clsql-nodb-error + :database database)) + diff --git a/base/db-interface.cl b/base/db-interface.cl new file mode 100644 index 0000000..b6c99f4 --- /dev/null +++ b/base/db-interface.cl @@ -0,0 +1,181 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: db-interface.cl +;;;; 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: db-interface.cl,v 1.4 2002/09/17 17:16:43 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 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. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :clsql-base-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-type (database) + (:documentation + "Returns database type") + (:method (database) + (signal-nodb-error database))) + + +(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-disconnect (database) + (:method ((database closed-database)) + (signal-closed-database-error database)) + (:method ((database t)) + (signal-nodb-error database)) + (:documentation "Internal generic implementation of disconnect.")) + +(defgeneric database-query (query-expression database types) + (:method (query-expression (database closed-database) types) + (declare (ignore query-expression types)) + (signal-closed-database-error database)) + (:method (query-expression (database t) types) + (declare (ignore query-expression types)) + (signal-nodb-error database)) + (:documentation "Internal generic implementation of query.")) + + +(defgeneric database-execute-command (sql-expression database) + (:method (sql-expression (database closed-database)) + (declare (ignore sql-expression)) + (signal-closed-database-error database)) + (:method (sql-expression (database t)) + (declare (ignore sql-expression)) + (signal-nodb-error database)) + (:documentation "Internal generic implementation of execute-command.")) + +;;; Mapping and iteration +(defgeneric database-query-result-set + (query-expression database &key full-set types) + (:method (query-expression (database closed-database) &key full-set types) + (declare (ignore query-expression full-set types)) + (signal-closed-database-error database) + (values nil nil nil)) + (:method (query-expression (database t) &key full-set types) + (declare (ignore query-expression full-set types)) + (signal-nodb-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 closed-database)) + (declare (ignore result-set)) + (signal-closed-database-error database)) + (:method (result-set (database t)) + (declare (ignore result-set)) + (signal-nodb-error database)) + (:documentation "Dumps the received result-set.")) + +(defgeneric database-store-next-row (result-set database list) + (:method (result-set (database closed-database) list) + (declare (ignore result-set list)) + (signal-closed-database-error database)) + (:method (result-set (database t) list) + (declare (ignore result-set list)) + (signal-nodb-error database)) + (:documentation + "Returns t and stores the next row in the result set in list or +returns nil when result-set is finished.")) + + +;; Interfaces to support UncommonSQL + +(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-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 (system-tables nil)) + (:documentation "List all tables in the given database")) + +(defgeneric database-list-attributes (table database) + (:documentation "List all attributes in TABLE.")) + +(defgeneric database-attribute-type (attribute table database) + (:documentation "Return the type of ATTRIBUTE in TABLE.")) + +(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.")) + + +;;; 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 string) 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")) diff --git a/base/initialize.cl b/base/initialize.cl new file mode 100644 index 0000000..6215376 --- /dev/null +++ b/base/initialize.cl @@ -0,0 +1,51 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: initialize.cl +;;;; Purpose: Initializion routines for backend +;;;; Programmers: Kevin M. Rosenberg +;;;; Date Started: May 2002 +;;;; +;;;; $Id: initialize.cl,v 1.4 2002/09/17 17:16:43 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 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. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :clsql-base-sys) + +(defvar *loaded-database-types* nil + "Contains a list of database types which have been defined/loaded.") + +(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. Currently only :mysql is +supported.") + +(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*'." + (if (member database-type *initialized-database-types*) + t + (when (database-initialize-database-type database-type) + (push database-type *initialized-database-types*) + t))) + + diff --git a/base/package.cl b/base/package.cl new file mode 100644 index 0000000..8f8fc4a --- /dev/null +++ b/base/package.cl @@ -0,0 +1,128 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: package.cl +;;;; 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: package.cl,v 1.8 2002/09/17 17:16:43 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 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. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :cl-user) + +;;;; This file makes the required package definitions for CLSQL's +;;;; core packages. + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defpackage :clsql-base-sys + (:use :common-lisp) + (:export + ;; "Private" exports for use by interface packages + #: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-query + #:database-execute-command + #:database-query-result-set + #:database-dump-result-set + #:database-store-next-row + + ;; For UncommonSQL support + #:database-list-tables + #:database-list-attributes + #:database-attribute-type + #:database-create-sequence + #:database-drop-sequence + #:database-sequence-next + #:sql-escape + + ;; Support for pooled connections + #:database-type + + ;; Large objects (Marc B) + #:database-create-large-object + #:database-write-large-object + #:database-read-large-object + #:database-delete-large-object + + ;; Shared exports for re-export by 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-connect-error + #:clsql-connect-error-database-type + #:clsql-connect-error-connection-spec + #:clsql-connect-error-errno + #:clsql-connect-error-error + #:clsql-sql-error + #:clsql-sql-error-database + #:clsql-sql-error-expression + #:clsql-sql-error-errno + #:clsql-sql-error-error + #:clsql-database-warning + #:clsql-database-warning-database + #:clsql-database-warning-message + #:clsql-exists-condition + #:clsql-exists-condition-new-db + #:clsql-exists-condition-old-db + #:clsql-exists-warning + #:clsql-exists-error + #:clsql-closed-error + #:clsql-closed-error-database + + #:*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 + #:closed-database + #:find-database + #:database-name-from-spec + + ;; accessors for database class + #:name + #:connection-spec + #:transaction + #:transaction-level + #:conn-pool + + ;; utils.cl + #:number-to-sql-string + #:float-to-sql-string + #:sql-escape-quotes + )) + (:documentation "This is the INTERNAL SQL-Interface package of CLSQL-BASE.")) + +(defpackage #:clsql-base + (:import-from :clsql-base-sys . #1#) + (:export . #1#) + (:documentation "This is the SQL-Interface package of CLSQL-BASE.")) +);eval-when + + diff --git a/base/utils.cl b/base/utils.cl new file mode 100644 index 0000000..93d5ece --- /dev/null +++ b/base/utils.cl @@ -0,0 +1,65 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: utils.cl +;;;; Purpose: SQL utility functions +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id: utils.cl,v 1.6 2002/09/17 17:16:43 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :clsql-base-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" + (substitute #\e #\f (substitute #\e #\d (write-to-string num :readably t)))) + +(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)) + + +(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))) + + diff --git a/clsql-aodbc.asd b/clsql-aodbc.asd index 7b04627..7e59816 100644 --- a/clsql-aodbc.asd +++ b/clsql-aodbc.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Aug 2002 ;;;; -;;;; $Id: clsql-aodbc.asd,v 1.5 2002/09/06 10:56:13 kevin Exp $ +;;;; $Id: clsql-aodbc.asd,v 1.6 2002/09/17 17:16:43 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -16,18 +16,16 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) (in-package :asdf) -(defsystem clsql-aodbc - :pathname #.(format nil "~A:clsql-aodbc;" - #+common-lisp-controller "cl-library" - #-common-lisp-controller "clsql") - :components ((:file "aodbc-package") - (:file "aodbc-sql" :depends-on ("aodbc-package"))) +(defsystem :clsql-aodbc + :components + ((:module :clsql-aodbc + :components + ((:file "aodbc-package") + (:file "aodbc-sql" :depends-on ("aodbc-package"))))) :depends-on (:clsql-base)) - (defmethod source-file-type ((c cl-source-file) (s (eql (find-system 'clsql-aodbc)))) "cl") diff --git a/clsql-aodbc.system b/clsql-aodbc.system deleted file mode 100644 index 315ea62..0000000 --- a/clsql-aodbc.system +++ /dev/null @@ -1,32 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: clsql-aodbc.system -;;;; Purpose: Defsystem-3/4 definition file for CLSQL AODBC backend -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: clsql-aodbc.system,v 1.11 2002/09/06 10:56:13 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :make) - -(defsystem :clsql-aodbc - :source-pathname #.(format nil "~A:clsql-aodbc;" - #+common-lisp-controller "cl-library" - #-common-lisp-controller "clsql") - - :source-extension "cl" - :components ((:file "aodbc-package") - (:file "aodbc-sql" :depends-on ("aodbc-package"))) - :depends-on (:clsql-base)) - - diff --git a/clsql-base.asd b/clsql-base.asd index 888f1f2..c45a806 100644 --- a/clsql-base.asd +++ b/clsql-base.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: clsql-base.asd,v 1.9 2002/09/06 11:08:19 kevin Exp $ +;;;; $Id: clsql-base.asd,v 1.10 2002/09/17 17:16:43 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -16,38 +16,21 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) (in-package :asdf) -;; For use with non-Common Lisp Controller installations -#-common-lisp-controller -(let ((path (make-pathname :name "set-logical" :type "cl" - :defaults *load-truename*))) - (when (probe-file path) - (load path) - (set-logical-host-for-pathname - "clsql" - (make-pathname :host (pathname-host *load-truename*) - :device (pathname-device *load-truename*) - :directory (pathname-directory *load-truename*))))) - - - ;;; System definitions - (defsystem clsql-base - :pathname #.(format nil "~A:clsql-base;" - #+common-lisp-controller "cl-library" - #-common-lisp-controller "clsql") :perform (load-op :after (op clsql-base) (pushnew :clsql-base cl:*features*)) - :components ((:file "cmucl-compat") - (:file "package") - (:file "utils" :depends-on ("package")) - (:file "classes" :depends-on ("package")) - (:file "conditions" :depends-on ("classes")) - (:file "db-interface" :depends-on ("conditions")) - (:file "initialize" :depends-on ("db-interface"))) - ) + :components + ((:module :base + :components + ((:file "cmucl-compat") + (:file "package") + (:file "utils" :depends-on ("package")) + (:file "classes" :depends-on ("package")) + (:file "conditions" :depends-on ("classes")) + (:file "db-interface" :depends-on ("conditions")) + (:file "initialize" :depends-on ("db-interface")))))) (defmethod source-file-type ((c cl-source-file) (s (eql (find-system 'clsql-base)))) diff --git a/clsql-base.system b/clsql-base.system deleted file mode 100644 index fd8e4d2..0000000 --- a/clsql-base.system +++ /dev/null @@ -1,50 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: clsql-base.system -;;;; Purpose: Defsystem-3/4 for Base CLSQL -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: clsql-base.system,v 1.12 2002/09/06 10:56:13 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :make) - -;; For use with non-Common Lisp Controller installations -#-common-lisp-controller -(let ((path (make-pathname :name "set-logical" :type "cl" - :defaults *load-truename*))) - (when (probe-file path) - (load path) - (set-logical-host-for-pathname - "clsql" - (make-pathname :host (pathname-host *load-truename*) - :device (pathname-device *load-truename*) - :directory (pathname-directory *load-truename*))))) - -;;; System definitions - -(defsystem :clsql-base - :source-pathname #.(format nil "~A:clsql-base;" - #+common-lisp-controller "cl-library" - #-common-lisp-controller "clsql") - :source-extension "cl" - :components ((:file "cmucl-compat") - (:file "package") - (:file "utils" :depends-on ("package")) - (:file "classes" :depends-on ("package")) - (:file "conditions" :depends-on ("classes")) - (:file "db-interface" :depends-on ("conditions")) - (:file "initialize" :depends-on ("db-interface"))) - :finally-do - (pushnew :clsql-base cl:*features*) - ) diff --git a/clsql-base/.cvsignore b/clsql-base/.cvsignore deleted file mode 100644 index ca8d09f..0000000 --- a/clsql-base/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -.bin diff --git a/clsql-base/Makefile b/clsql-base/Makefile deleted file mode 100644 index 31dc910..0000000 --- a/clsql-base/Makefile +++ /dev/null @@ -1,6 +0,0 @@ -SUBDIRS := - -include ../Makefile.common - -.PHONY: distclean -distclean: clean diff --git a/clsql-base/classes.cl b/clsql-base/classes.cl deleted file mode 100644 index 315fae9..0000000 --- a/clsql-base/classes.cl +++ /dev/null @@ -1,55 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: classes.cl -;;;; Purpose: Classes for High-level SQL interface -;;;; Programmers: Kevin M. Rosenberg based on -;;;; original code by Pierre R. Mai -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: classes.cl,v 1.1 2002/08/01 03:06:26 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 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. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-base-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") - (transaction-level :initform 0 :accessor transaction-level) - (transaction :initform nil :accessor transaction) - (conn-pool :initform nil :initarg :conn-pool :accessor conn-pool)) - (: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) - (write-string (if (slot-boundp object 'name) - (database-name object) - "") - stream))) - -;; Closed database idea and original code comes from UncommonSQL - -(defclass closed-database () - ((name :initarg :name :reader database-name)) - (:documentation - "This class represents databases after they are closed via 'disconnect'.")) - -(defmethod print-object ((object closed-database) stream) - (print-unreadable-object (object stream :type t :identity t) - (write-string (if (slot-boundp object 'name) - (database-name object) - "") - stream))) - diff --git a/clsql-base/cmucl-compat.cl b/clsql-base/cmucl-compat.cl deleted file mode 100644 index e18fa0c..0000000 --- a/clsql-base/cmucl-compat.cl +++ /dev/null @@ -1,115 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: cmucl-compat.sql -;;;; Purpose: Compatiblity library for CMUCL functions -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: cmucl-compat.cl,v 1.1 2002/08/01 03:06:26 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :cl-user) - -(defpackage :cmucl-compat - (:export - #:shrink-vector - #:make-sequence-of-type - #:result-type-or-lose - #:required-argument - )) -(in-package :cmucl-compat) - -#+cmu -(defmacro required-argument () - `(ext:required-argument)) - -#-cmu -(defun required-argument () - (error "~&A required keyword argument was not supplied")) - -#+cmu -(defmacro shrink-vector (vec len) - `(lisp::shrink-vector ,vec ,len)) - -#-cmu -(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)))) - (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))) - ))) - - - -#-cmu -(defun make-sequence-of-type (type length) - "Returns a sequence of the given TYPE and LENGTH." - (declare (fixnum length)) - (case type - (list - (make-list length)) - ((bit-vector simple-bit-vector) - (make-array length :element-type '(mod 2))) - ((string simple-string base-string simple-base-string) - (make-string length)) - (simple-vector - (make-array length)) - ((array simple-array vector) - (if (listp type) - (make-array length :element-type (cadr type)) - (make-array length))) - (t - (make-sequence-of-type (result-type-or-lose type t) length)))) - - -#+cmu -(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) - (system::make-sequence-of-type type len))) - - -#-cmu -(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)) - )) - -#+cmu -(defun result-type-or-lose (type nil-ok) - (lisp::result-type-or-lose type nil-ok)) diff --git a/clsql-base/conditions.cl b/clsql-base/conditions.cl deleted file mode 100644 index 4371ccc..0000000 --- a/clsql-base/conditions.cl +++ /dev/null @@ -1,160 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: conditions.cl -;;;; 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: conditions.cl,v 1.1 2002/08/01 03:06:26 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 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. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-base-sys) - -;;; 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-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 ,@template)) - t) - (error () (error 'clsql-invalid-spec-error - :connection-spec ,connection-spec - :database-type ,database-type - :template (quote ,template))))) - -(define-condition clsql-connect-error (clsql-error) - ((database-type :initarg :database-type - :reader clsql-connect-error-database-type) - (connection-spec :initarg :connection-spec - :reader clsql-connect-error-connection-spec) - (errno :initarg :errno :reader clsql-connect-error-errno) - (error :initarg :error :reader clsql-connect-error-error)) - (: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-connect-error-connection-spec c) - (clsql-connect-error-database-type c)) - (clsql-connect-error-database-type c) - (clsql-connect-error-errno c) - (clsql-connect-error-error c))))) - -(define-condition clsql-sql-error (clsql-error) - ((database :initarg :database :reader clsql-sql-error-database) - (expression :initarg :expression :reader clsql-sql-error-expression) - (errno :initarg :errno :reader clsql-sql-error-errno) - (error :initarg :error :reader clsql-sql-error-error)) - (:report (lambda (c stream) - (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-nodb-error (clsql-error) - ((database :initarg :database :reader clsql-nodb-error-database)) - (:report (lambda (c stream) - (format stream "No such database ~S is open." - (clsql-nodb-error-database c))))) - - -;; Signal conditions - - -(defun signal-closed-database-error (database) - (cerror "Ignore this error and return nil." - 'clsql-closed-error - :database database)) - -(defun signal-nodb-error (database) - (cerror "Ignore this error and return nil." - 'clsql-nodb-error - :database database)) - diff --git a/clsql-base/db-interface.cl b/clsql-base/db-interface.cl deleted file mode 100644 index 479534e..0000000 --- a/clsql-base/db-interface.cl +++ /dev/null @@ -1,181 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: db-interface.cl -;;;; 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: db-interface.cl,v 1.1 2002/08/01 03:06:26 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 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. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-base-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-type (database) - (:documentation - "Returns database type") - (:method (database) - (signal-nodb-error database))) - - -(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-disconnect (database) - (:method ((database closed-database)) - (signal-closed-database-error database)) - (:method ((database t)) - (signal-nodb-error database)) - (:documentation "Internal generic implementation of disconnect.")) - -(defgeneric database-query (query-expression database types) - (:method (query-expression (database closed-database) types) - (declare (ignore query-expression types)) - (signal-closed-database-error database)) - (:method (query-expression (database t) types) - (declare (ignore query-expression types)) - (signal-nodb-error database)) - (:documentation "Internal generic implementation of query.")) - - -(defgeneric database-execute-command (sql-expression database) - (:method (sql-expression (database closed-database)) - (declare (ignore sql-expression)) - (signal-closed-database-error database)) - (:method (sql-expression (database t)) - (declare (ignore sql-expression)) - (signal-nodb-error database)) - (:documentation "Internal generic implementation of execute-command.")) - -;;; Mapping and iteration -(defgeneric database-query-result-set - (query-expression database &key full-set types) - (:method (query-expression (database closed-database) &key full-set types) - (declare (ignore query-expression full-set types)) - (signal-closed-database-error database) - (values nil nil nil)) - (:method (query-expression (database t) &key full-set types) - (declare (ignore query-expression full-set types)) - (signal-nodb-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 closed-database)) - (declare (ignore result-set)) - (signal-closed-database-error database)) - (:method (result-set (database t)) - (declare (ignore result-set)) - (signal-nodb-error database)) - (:documentation "Dumps the received result-set.")) - -(defgeneric database-store-next-row (result-set database list) - (:method (result-set (database closed-database) list) - (declare (ignore result-set list)) - (signal-closed-database-error database)) - (:method (result-set (database t) list) - (declare (ignore result-set list)) - (signal-nodb-error database)) - (:documentation - "Returns t and stores the next row in the result set in list or -returns nil when result-set is finished.")) - - -;; Interfaces to support UncommonSQL - -(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-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 (system-tables nil)) - (:documentation "List all tables in the given database")) - -(defgeneric database-list-attributes (table database) - (:documentation "List all attributes in TABLE.")) - -(defgeneric database-attribute-type (attribute table database) - (:documentation "Return the type of ATTRIBUTE in TABLE.")) - -(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.")) - - -;;; 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 string) 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")) diff --git a/clsql-base/initialize.cl b/clsql-base/initialize.cl deleted file mode 100644 index 0380f70..0000000 --- a/clsql-base/initialize.cl +++ /dev/null @@ -1,51 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: initialize.cl -;;;; Purpose: Initializion routines for backend -;;;; Programmers: Kevin M. Rosenberg -;;;; Date Started: May 2002 -;;;; -;;;; $Id: initialize.cl,v 1.1 2002/08/01 03:06:26 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 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. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-base-sys) - -(defvar *loaded-database-types* nil - "Contains a list of database types which have been defined/loaded.") - -(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. Currently only :mysql is -supported.") - -(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*'." - (if (member database-type *initialized-database-types*) - t - (when (database-initialize-database-type database-type) - (push database-type *initialized-database-types*) - t))) - - diff --git a/clsql-base/package.cl b/clsql-base/package.cl deleted file mode 100644 index dfca868..0000000 --- a/clsql-base/package.cl +++ /dev/null @@ -1,128 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: package.cl -;;;; 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: package.cl,v 1.1 2002/08/01 03:06:26 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 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. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :cl-user) - -;;;; This file makes the required package definitions for CLSQL's -;;;; core packages. - -(eval-when (:compile-toplevel :load-toplevel :execute) -(defpackage :clsql-base-sys - (:use :common-lisp) - (:export - ;; "Private" exports for use by interface packages - #: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-query - #:database-execute-command - #:database-query-result-set - #:database-dump-result-set - #:database-store-next-row - - ;; For UncommonSQL support - #:database-list-tables - #:database-list-attributes - #:database-attribute-type - #:database-create-sequence - #:database-drop-sequence - #:database-sequence-next - #:sql-escape - - ;; Support for pooled connections - #:database-type - - ;; Large objects (Marc B) - #:database-create-large-object - #:database-write-large-object - #:database-read-large-object - #:database-delete-large-object - - ;; Shared exports for re-export by 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-connect-error - #:clsql-connect-error-database-type - #:clsql-connect-error-connection-spec - #:clsql-connect-error-errno - #:clsql-connect-error-error - #:clsql-sql-error - #:clsql-sql-error-database - #:clsql-sql-error-expression - #:clsql-sql-error-errno - #:clsql-sql-error-error - #:clsql-database-warning - #:clsql-database-warning-database - #:clsql-database-warning-message - #:clsql-exists-condition - #:clsql-exists-condition-new-db - #:clsql-exists-condition-old-db - #:clsql-exists-warning - #:clsql-exists-error - #:clsql-closed-error - #:clsql-closed-error-database - - #:*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 - #:closed-database - #:find-database - #:database-name-from-spec - - ;; accessors for database class - #:name - #:connection-spec - #:transaction - #:transaction-level - #:conn-pool - - ;; utils.cl - #:number-to-sql-string - #:float-to-sql-string - #:sql-escape-quotes - )) - (:documentation "This is the INTERNAL SQL-Interface package of CLSQL-BASE.")) - -(defpackage #:clsql-base - (:import-from :clsql-base-sys . #1#) - (:export . #1#) - (:documentation "This is the SQL-Interface package of CLSQL-BASE.")) -);eval-when - - diff --git a/clsql-base/utils.cl b/clsql-base/utils.cl deleted file mode 100644 index b26ee9e..0000000 --- a/clsql-base/utils.cl +++ /dev/null @@ -1,65 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: utils.cl -;;;; Purpose: SQL utility functions -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Mar 2002 -;;;; -;;;; $Id: utils.cl,v 1.1 2002/08/01 03:06:26 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-base-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" - (substitute #\e #\f (substitute #\e #\d (write-to-string num :readably t)))) - -(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)) - - -(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))) - - diff --git a/clsql-mysql.asd b/clsql-mysql.asd index 9e17055..0af451f 100644 --- a/clsql-mysql.asd +++ b/clsql-mysql.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Aug 2002 ;;;; -;;;; $Id: clsql-mysql.asd,v 1.5 2002/09/06 10:56:13 kevin Exp $ +;;;; $Id: clsql-mysql.asd,v 1.6 2002/09/17 17:16:43 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -22,19 +22,17 @@ ;;; System definition -(defsystem clsql-mysql - :pathname #.(format nil "~A:clsql-mysql;" - #+common-lisp-controller "cl-library" - #-common-lisp-controller "clsql") - :components ((:file "mysql-package") - (:file "mysql-loader" :depends-on ("mysql-package")) - (:file "mysql-api" :depends-on ("mysql-loader")) - (:file "mysql-sql" :depends-on ("mysql-api")) - (:file "mysql-usql" :depends-on ("mysql-sql"))) - :depends-on (:uffi :clsql-base :clsql-uffi)) - - +(defsystem :clsql-mysql + :components + ((:module :mysql + :components + ((:file "mysql-package") + (:file "mysql-loader" :depends-on ("mysql-package")) + (:file "mysql-api" :depends-on ("mysql-loader")) + (:file "mysql-sql" :depends-on ("mysql-api")) + (:file "mysql-usql" :depends-on ("mysql-sql"))))) + :depends-on (:uffi :clsql-base :clsql-uffi)) + (defmethod source-file-type ((c cl-source-file) (s (eql (find-system 'clsql-mysql)))) "cl") - diff --git a/clsql-mysql.system b/clsql-mysql.system deleted file mode 100644 index 5bea359..0000000 --- a/clsql-mysql.system +++ /dev/null @@ -1,40 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: clsql-mysql.system -;;;; Purpose: Defsystem-3/4 definition file for CLSQL MySQL backend -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: clsql-mysql.system,v 1.18 2002/09/06 10:56:13 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) - -(in-package :make) - -;;; System definition - -(defsystem :clsql-mysql - :source-pathname #.(format nil "~A:clsql-mysql;" - #+common-lisp-controller "cl-library" - #-common-lisp-controller "clsql") - :source-extension "cl" - :components ((:file "mysql-package") - (:file "mysql-loader" :depends-on ("mysql-package")) - (:file "mysql-api" :depends-on ("mysql-loader")) - (:file "mysql-sql" :depends-on ("mysql-api")) - (:file "mysql-usql" :depends-on ("mysql-sql"))) - :depends-on (:uffi :clsql-base :clsql-uffi)) - - - - - diff --git a/clsql-oracle.asd b/clsql-oracle.asd index b694792..9227721 100644 --- a/clsql-oracle.asd +++ b/clsql-oracle.asd @@ -1,28 +1,25 @@ ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; This is copyrighted software. See interfaces/oracle/* files for terms. ;;;; -;;;; $Id: clsql-oracle.asd,v 1.5 2002/09/06 10:56:13 kevin Exp $ +;;;; $Id: clsql-oracle.asd,v 1.6 2002/09/17 17:16:43 kevin Exp $ (in-package :asdf) ;;; System definition (defsystem :clsql-oracle - :pathname #.(format nil "~A:clsql-oracle;" - #+common-lisp-controller "cl-library" - #-common-lisp-controller "clsql") - :pathname "cl-library:clsql-oracle" :components - ((:file "oracle-package") - (:file "oracle-loader" :depends-on ("oracle-package")) - (:file "alien-resources" :depends-on ("oracle-package")) - (:file "oracle-constants" :depends-on ("oracle-package")) - (:file "oracle" :depends-on ("oracle-constants" "oracle-loader")) - (:file "oracle-sql" :depends-on ("oracle" "alien-resources")) - (:file "oracle-objects" :depends-on ("oracle-sql"))) + ((:module :clsql-oracle + :components + ((:file "oracle-package") + (:file "oracle-loader" :depends-on ("oracle-package")) + (:file "alien-resources" :depends-on ("oracle-package")) + (:file "oracle-constants" :depends-on ("oracle-package")) + (:file "oracle" :depends-on ("oracle-constants" "oracle-loader")) + (:file "oracle-sql" :depends-on ("oracle" "alien-resources")) + (:file "oracle-objects" :depends-on ("oracle-sql"))))) :depends-on (:clsql-base)) - (defmethod source-file-type ((c cl-source-file) (s (eql (find-system 'clsql-oracle)))) "cl") diff --git a/clsql-oracle.system b/clsql-oracle.system deleted file mode 100644 index c52957f..0000000 --- a/clsql-oracle.system +++ /dev/null @@ -1,27 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; This is copyrighted software. See interfaces/oracle/* files for terms. -;;;; -;;;; $Id: clsql-oracle.system,v 1.5 2002/09/06 10:56:13 kevin Exp $ - -(in-package :make) - -;;; System definition - -(defsystem :clsql-oracle - :source-pathname #.(format nil "~A:clsql-oracle;" - #+common-lisp-controller "cl-library" - #-common-lisp-controller "clsql") - :source-extension "cl" - :components - ((:file "oracle-package") - (:file "oracle-loader" :depends-on ("oracle-package")) - (:file "alien-resources" :depends-on ("oracle-package")) - (:file "oracle-constants" :depends-on ("oracle-package")) - (:file "oracle" :depends-on ("oracle-constants" "oracle-loader")) - (:file "oracle-sql" :depends-on ("oracle" "alien-resources")) - (:file "oracle-objects" :depends-on ("oracle-sql"))) - :depends-on (:clsql-base)) - - - - diff --git a/clsql-postgresql-socket.asd b/clsql-postgresql-socket.asd index 74b631f..7c80ab2 100644 --- a/clsql-postgresql-socket.asd +++ b/clsql-postgresql-socket.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Aug 2002 ;;;; -;;;; $Id: clsql-postgresql-socket.asd,v 1.5 2002/09/06 10:56:13 kevin Exp $ +;;;; $Id: clsql-postgresql-socket.asd,v 1.6 2002/09/17 17:16:43 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -22,15 +22,15 @@ ;;; System definition (defsystem clsql-postgresql-socket - :pathname #.(format nil "~A:clsql-postgresql-socket;" - #+common-lisp-controller "cl-library" - #-common-lisp-controller "clsql") - :components ((:file "postgresql-socket-package") - (:file "postgresql-socket-api" - :depends-on ("postgresql-socket-package")) - (:file "postgresql-socket-sql" - :depends-on ("postgresql-socket-api"))) - :depends-on (:clsql-base :uffi)) + :components + ((:module :clsql-postgresql-socket + :components + ((:file "postgresql-socket-package") + (:file "postgresql-socket-api" + :depends-on ("postgresql-socket-package")) + (:file "postgresql-socket-sql" + :depends-on ("postgresql-socket-api"))))) + :depends-on (:clsql-base :uffi)) (defmethod source-file-type ((c cl-source-file) (s (eql (find-system 'clsql-postgresql-socket)))) diff --git a/clsql-postgresql-socket.system b/clsql-postgresql-socket.system deleted file mode 100644 index e4ee7b0..0000000 --- a/clsql-postgresql-socket.system +++ /dev/null @@ -1,34 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: clsql-postgresql.system -;;;; Purpose: Defsystem-3/4 file for CLSQL PostgresSQL socket backend -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: clsql-postgresql-socket.system,v 1.12 2002/09/06 10:56:13 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :make) - -;;; System definition - -(defsystem :clsql-postgresql-socket - :source-pathname #.(format nil "~A:clsql-postgresql-socket;" - #+common-lisp-controller "cl-library" - #-common-lisp-controller "clsql") - :source-extension "cl" - :components ((:file "postgresql-socket-package") - (:file "postgresql-socket-api" - :depends-on ("postgresql-socket-package")) - (:file "postgresql-socket-sql" - :depends-on ("postgresql-socket-api"))) - :depends-on (:clsql-base :uffi)) diff --git a/clsql-postgresql.asd b/clsql-postgresql.asd index 46b26e6..bc4b2bf 100644 --- a/clsql-postgresql.asd +++ b/clsql-postgresql.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Aug 2002 ;;;; -;;;; $Id: clsql-postgresql.asd,v 1.5 2002/09/06 10:56:13 kevin Exp $ +;;;; $Id: clsql-postgresql.asd,v 1.6 2002/09/17 17:16:43 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -19,17 +19,16 @@ (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) (in-package :asdf) -(defsystem clsql-postgresql - :pathname #.(format nil "~A:clsql-postgresql;" - #+common-lisp-controller "cl-library" - #-common-lisp-controller "clsql") - :components ((:file "postgresql-package") - (:file "postgresql-loader" :depends-on ("postgresql-package")) - (:file "postgresql-api" :depends-on ("postgresql-loader")) - (:file "postgresql-sql" :depends-on ("postgresql-api")) - (:file "postgresql-usql" :depends-on ("postgresql-sql"))) - :depends-on (:uffi :clsql-base :clsql-uffi)) - +(defsystem :clsql-postgresql + :components + ((:module :clsql-postgresql + :components + ((:file "postgresql-package") + (:file "postgresql-loader" :depends-on ("postgresql-package")) + (:file "postgresql-api" :depends-on ("postgresql-loader")) + (:file "postgresql-sql" :depends-on ("postgresql-api")) + (:file "postgresql-usql" :depends-on ("postgresql-sql"))))) + :depends-on (:uffi :clsql-base :clsql-uffi)) (defmethod source-file-type ((c cl-source-file) (s (eql (find-system 'clsql-postgresql)))) diff --git a/clsql-postgresql.system b/clsql-postgresql.system deleted file mode 100644 index 5d4ecea..0000000 --- a/clsql-postgresql.system +++ /dev/null @@ -1,33 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: clsql-postgresql.system -;;;; Purpose: Defsystem-3/4 file for CLSQL PostgresSQL backend -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: clsql-postgresql.system,v 1.12 2002/09/06 10:56:13 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :make) - -(defsystem :clsql-postgresql - :source-pathname #.(format nil "~A:clsql-postgresql;" - #+common-lisp-controller "cl-library" - #-common-lisp-controller "clsql") - :source-extension "cl" - :components ((:file "postgresql-package") - (:file "postgresql-loader" :depends-on ("postgresql-package")) - (:file "postgresql-api" :depends-on ("postgresql-loader")) - (:file "postgresql-sql" :depends-on ("postgresql-api")) - (:file "postgresql-usql" :depends-on ("postgresql-sql"))) - :depends-on (:uffi :clsql-base :clsql-uffi)) - diff --git a/clsql-uffi.asd b/clsql-uffi.asd index 8ecdc35..c45d31c 100644 --- a/clsql-uffi.asd +++ b/clsql-uffi.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Aug 2002 ;;;; -;;;; $Id: clsql-uffi.asd,v 1.7 2002/09/06 10:56:13 kevin Exp $ +;;;; $Id: clsql-uffi.asd,v 1.8 2002/09/17 17:16:43 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -22,17 +22,16 @@ ;;; System definition -(defsystem clsql-uffi - :pathname #.(format nil "~A:clsql-uffi;" - #+common-lisp-controller "cl-library" - #-common-lisp-controller "clsql") - :components ((:file "clsql-uffi-package") - (:file "clsql-uffi-loader" :depends-on ("clsql-uffi-package")) - (:file "clsql-uffi" :depends-on ("clsql-uffi-loader"))) +(defsystem :clsql-uffi + :components + ((:module :uffi + :components + ((:file "clsql-uffi-package") + (:file "clsql-uffi-loader" :depends-on ("clsql-uffi-package")) + (:file "clsql-uffi" :depends-on ("clsql-uffi-loader"))))) :depends-on (:uffi :clsql-base)) (defmethod source-file-type ((c cl-source-file) (s (eql (find-system 'clsql-uffi)))) "cl") - diff --git a/clsql-uffi.system b/clsql-uffi.system deleted file mode 100644 index cb820b8..0000000 --- a/clsql-uffi.system +++ /dev/null @@ -1,34 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: clsql-uffi.system -;;;; Purpose: Defsystem-3/4 definition file for CLSQL UFFI Helper package -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: clsql-uffi.system,v 1.9 2002/09/06 10:56:13 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) - -(in-package :make) - -;;; System definition - -(defsystem :clsql-uffi - :source-pathname #.(format nil "~A:clsql-uffi;" - #+common-lisp-controller "cl-library" - #-common-lisp-controller "clsql") - :source-extension "cl" - :components ((:file "clsql-uffi-package") - (:file "clsql-uffi-loader" :depends-on ("clsql-uffi-package")) - (:file "clsql-uffi" :depends-on ("clsql-uffi-loader"))) - :depends-on (:uffi :clsql-base)) - diff --git a/clsql.asd b/clsql.asd index d588c91..1625200 100644 --- a/clsql.asd +++ b/clsql.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: clsql.asd,v 1.6 2002/09/06 11:08:19 kevin Exp $ +;;;; $Id: clsql.asd,v 1.7 2002/09/17 17:16:43 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -16,36 +16,24 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) - (in-package :asdf) -#-clsql-base -(let ((path (make-pathname :name "clsql-base" :type "system" - :defaults *load-truename*))) - (when (probe-file path) - (load path))) - -;;; System definitions - - (defsystem clsql - :pathname #.(format nil "~A:clsql;" - #+common-lisp-controller "cl-library" - #-common-lisp-controller "clsql") :perform (load-op :after (op clsql) (pushnew :clsql cl:*features*)) - :components ((:file "package") - (:file "pool" :depends-on ("package")) - (:file "loop-extension") - (:file "sql" :depends-on ("pool")) - (:file "transactions" :depends-on ("sql")) - (:file "functional" :depends-on ("sql")) - (:file "usql" :depends-on ("sql"))) + :components + ((:module :sql + :components + ((:file "package") + (:file "pool" :depends-on ("package")) + (:file "loop-extension") + (:file "sql" :depends-on ("pool")) + (:file "transactions" :depends-on ("sql")) + (:file "functional" :depends-on ("sql")) + (:file "usql" :depends-on ("sql"))))) :depends-on (:clsql-base) ) (defmethod source-file-type ((c cl-source-file) (s (eql (find-system 'clsql)))) "cl") - diff --git a/clsql.system b/clsql.system deleted file mode 100644 index ef655b8..0000000 --- a/clsql.system +++ /dev/null @@ -1,45 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: clsql.system -;;;; Purpose: Defsystem-3/4 for CLSQL -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: clsql.system,v 1.20 2002/09/06 10:56:13 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :make) - -#-clsql-base -(let ((path (make-pathname :name "clsql-base" :type "system" - :defaults *load-truename*))) - (when (probe-file path) - (load path))) - -;;; System definitions - -(defsystem :clsql - :source-pathname #.(format nil "~A:clsql;" - #+common-lisp-controller "cl-library" - #-common-lisp-controller "clsql") - :source-extension "cl" - :components ((:file "package") - (:file "pool" :depends-on ("package")) - (:file "loop-extension") - (:file "sql" :depends-on ("pool")) - (:file "transactions" :depends-on ("sql")) - (:file "functional" :depends-on ("sql")) - (:file "usql" :depends-on ("sql"))) - :depends-on (:clsql-base) - :finally-do - (pushnew :clsql cl:*features*) - ) diff --git a/clsql/.cvsignore b/clsql/.cvsignore deleted file mode 100755 index ca8d09f..0000000 --- a/clsql/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -.bin diff --git a/clsql/Makefile b/clsql/Makefile deleted file mode 100644 index 31dc910..0000000 --- a/clsql/Makefile +++ /dev/null @@ -1,6 +0,0 @@ -SUBDIRS := - -include ../Makefile.common - -.PHONY: distclean -distclean: clean diff --git a/clsql/functional.cl b/clsql/functional.cl deleted file mode 100644 index 01d0590..0000000 --- a/clsql/functional.cl +++ /dev/null @@ -1,99 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: functional.cl -;;;; Purpose: Functional interface -;;;; Programmer: Pierre R. Mai -;;;; -;;;; Copyright (c) 1999-2001 Pierre R. Mai -;;;; -;;;; $Id: functional.cl,v 1.1 2002/08/01 03:06:26 kevin Exp $ -;;;; -;;;; This file is part of CLSQL. -;;;; -;;;; CLSQL is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License (version 2) as -;;;; published by the Free Software Foundation. -;;;; -;;;; CLSQL is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with CLSQL; if not, write to the Free Software Foundation, Inc., -;;;; 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-sys) - - -;;;; This file implements the more advanced functions of the -;;;; functional SQL interface, which are just nicer layers above the -;;;; basic SQL interface. - -(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)))) - -(defmacro with-database ((db-var connection-spec &rest connect-args) &body body) - "Evaluate the body in an environment, where `db-var' is bound to the -database connection given by `connection-spec' and `connect-args'. -The connection is automatically closed or released to the pool on exit from the body." - (let ((result (gensym "result-"))) - (unless db-var (setf db-var '*default-database*)) - `(let ((,db-var (connect ,connection-spec ,@connect-args)) - (,result nil)) - (unwind-protect - (let ((,db-var ,db-var)) - (setf ,result (progn ,@body))) - (disconnect :database ,db-var)) - ,result))) \ No newline at end of file diff --git a/clsql/loop-extension.cl b/clsql/loop-extension.cl deleted file mode 100644 index a1651b9..0000000 --- a/clsql/loop-extension.cl +++ /dev/null @@ -1,98 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: loop-extension.cl -;;;; Purpose: Extensions to the Loop macro for CMUCL -;;;; Programmer: Pierre R. Mai -;;;; -;;;; Copyright (c) 1999-2001 Pierre R. Mai -;;;; -;;;; $Id: loop-extension.cl,v 1.1 2002/08/01 03:06:26 kevin Exp $ -;;;; -;;;; The functions in this file were orignally distributed in the -;;;; MaiSQL package in the file sql/sql.cl -;;;; ************************************************************************* - -(in-package :cl-user) - -;;;; MIT-LOOP extension - -#+cmu -(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 '(*default-database*))) - (cond - ((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 - (database-dump-result-set ,result-set-var ,db-var)) - ansi-loop::*loop-epilogue*) - `(((,variable nil ,data-type) (,query-var ,(first in-phrase)) - (,db-var ,(first from-phrase)) - (,result-set-var nil) - (,step-var nil)) - ((multiple-value-bind (%rs %cols) - (database-query-result-set ,query-var ,db-var) - (setq ,result-set-var %rs ,step-var (make-list %cols)))) - () - () - (not (database-store-next-row ,result-set-var ,db-var ,step-var)) - (,variable ,step-var) - (not ,result-set-var) - () - (not (database-store-next-row ,result-set-var ,db-var ,step-var)) - (,variable ,step-var)))) - (t - (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-))) - (push `(when ,result-set-var - (database-dump-result-set ,result-set-var ,db-var)) - ansi-loop::*loop-epilogue*) - `(((,variable nil ,data-type) (,query-var ,(first in-phrase)) - (,db-var ,(first from-phrase)) - (,result-set-var nil)) - ((multiple-value-bind (%rs %cols) - (database-query-result-set ,query-var ,db-var) - (setq ,result-set-var %rs ,variable (make-list %cols)))) - () - () - (not (database-store-next-row ,result-set-var ,db-var ,variable)) - () - (not ,result-set-var) - () - (not (database-store-next-row ,result-set-var ,db-var ,variable)) - ())))))) - -#+cmu -(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) diff --git a/clsql/package.cl b/clsql/package.cl deleted file mode 100644 index bf4eb00..0000000 --- a/clsql/package.cl +++ /dev/null @@ -1,133 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: package.cl -;;;; Purpose: Package definition for CLSQL (high-level) interface -;;;; Programmers: Kevin M. Rosenberg based on -;;;; Original code by Pierre R. Mai -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: package.cl,v 1.1 2002/08/01 03:06:26 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 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. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :cl-user) - - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defpackage :clsql-sys - (:nicknames :clsql) - (:use :common-lisp :clsql-base-sys) - (: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-connect-error - #:clsql-connect-error-database-type - #:clsql-connect-error-connection-spec - #:clsql-connect-error-errno - #:clsql-connect-error-error - #:clsql-sql-error - #:clsql-sql-error-database - #:clsql-sql-error-expression - #:clsql-sql-error-errno - #:clsql-sql-error-error - #:clsql-database-warning - #:clsql-database-warning-database - #:clsql-database-warning-message - #:clsql-exists-condition - #:clsql-exists-condition-new-db - #:clsql-exists-condition-old-db - #:clsql-exists-warning - #:clsql-exists-error - #:clsql-closed-error - #:clsql-closed-error-database - - #:*loaded-database-types* - #:reload-database-types - #:*default-database-type* - #:*initialized-database-types* - #:initialize-database-type - - #:database - #:database-name - #:closed-database - #:database-name-from-spec - - ;; utils.cl - #:number-to-sql-string - #:float-to-sql-string - #:sql-escape-quotes - )) - (:export - ;; sql.cl - #:*connect-if-exists* - #:connected-databases - #:*default-database* - #:find-database - #:connect - #:disconnect - #:query - #:execute-command - #:map-query - #:do-query - - ;; functional.cl - #:insert-records - #:delete-records - #:update-records - #:with-database - - ;; For High-level UncommonSQL compatibility - #:sql-ident - #:list-tables - #:list-attributes - #:attribute-type - #:create-sequence - #:drop-sequence - #:sequence-next - - ;; Pooled connections - #:disconnect-pooled - #:find-or-create-connection-pool - - ;; Transactions - #:with-transaction - #:commit-transaction - #:rollback-transaction - #:add-transaction-commit-hook - #:add-transaction-rollback-hook - - ;; Large objects (Marc B) - #:create-large-object - #:write-large-object - #:read-large-object - #:delete-large-object - - . - #1# - ) - (:documentation "This is the INTERNAL SQL-Interface package of CLSQL.")) - - ) ;eval-when - -(defpackage #:clsql-user - (:use #:common-lisp #:clsql) - (:documentation "This is the user package for experimenting with CLSQL.")) diff --git a/clsql/pool.cl b/clsql/pool.cl deleted file mode 100644 index 3aa8d25..0000000 --- a/clsql/pool.cl +++ /dev/null @@ -1,79 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: pool.cl -;;;; Purpose: Support function for connection pool -;;;; Programmers: Kevin M. Rosenberg, Marc Battyani -;;;; Date Started: Apr 2002 -;;;; -;;;; $Id: pool.cl,v 1.1 2002/08/01 03:06:26 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-sys) - -(defvar *db-pool* (make-hash-table :test #'equal)) - -(defclass conn-pool () - ((connection-spec :accessor connection-spec :initarg :connection-spec) - (database-type :accessor database-type :initarg :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)))) - -(defun acquire-from-conn-pool (pool) - (if (zerop (length (free-connections pool))) - (let ((conn (connect (connection-spec pool) - :database-type (database-type pool) :if-exists :new))) - (vector-push-extend conn (all-connections pool)) - (setf (conn-pool conn) pool) - conn) - (vector-pop (free-connections pool)))) - -(defun release-to-conn-pool (conn) - (vector-push-extend conn (free-connections (conn-pool conn)))) - -(defun clear-conn-pool (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)) - -(defun find-or-create-connection-pool (connection-spec database-type) - "Find connection pool in hash table, creates a new connection pool if not found" - (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 - :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" - (maphash - #'(lambda (key conn-pool) - (declare (ignore key)) - (clear-conn-pool conn-pool)) - *db-pool*) - (when clear (clrhash *db-pool*)) - t) - diff --git a/clsql/sql.cl b/clsql/sql.cl deleted file mode 100644 index 1adedf7..0000000 --- a/clsql/sql.cl +++ /dev/null @@ -1,262 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: sql.cl -;;;; Purpose: High-level SQL interface -;;;; Programmers: Kevin M. Rosenberg based on -;;;; Original code by Pierre R. Mai -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: sql.cl,v 1.1 2002/08/01 03:06:26 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 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. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-sys) - -;;; Modified by KMR -;;; - to use CMUCL-COMPAT library -;;; - fix format strings in error messages -;;; - use field types - - -;;; Simple implementation of SQL along the lines of Harlequin's Common SQL - - -;;; Database handling - -(defvar *connect-if-exists* :error - "Default value for the if-exists parameter of connect calls.") - -(defvar *connected-databases* nil - "List of active database objects.") - -(defun connected-databases () - "Return the list of active database objects." - *connected-databases*) - -(defvar *default-database* nil - "Specifies the default database to be used.") - -(defun find-database (database &optional (errorp t)) - (etypecase database - (database - ;; Return the database object itself - database) - (string - (or (find database (connected-databases) - :key #'database-name - :test #'string=) - (when errorp - (cerror "Return nil." - 'clsql-simple-error - :format-control "There exists no database called ~A." - :format-arguments (list database))))))) - -(defun connect (connection-spec - &key (if-exists *connect-if-exists*) - (database-type *default-database-type*) - (pool nil)) - "Connects to a database of the given database-type, using the type-specific -connection-spec. if-exists is currently ignored. -If pool is t the the connection will be taken from the general pool, -if pool is a conn-pool object the connection will be taken from this pool. -" - (if pool - (acquire-from-pool connection-spec database-type pool) - (let* ((db-name (database-name-from-spec connection-spec database-type)) - (old-db (unless (eq if-exists :new) (find-database db-name nil))) - (result nil)) - (if old-db - (case if-exists -; (:new -; (setq result -; (database-connect connection-spec database-type))) - (:warn-new - (setq result - (database-connect connection-spec database-type)) - (warn 'clsql-exists-warning :old-db old-db :new-db result)) - (:error - (restart-case - (error 'clsql-exists-error :old-db old-db) - (create-new () - :report "Create a new connection." - (setq result - (database-connect connection-spec database-type))) - (use-old () - :report "Use the existing connection." - (setq result old-db)))) - (:warn-old - (setq result old-db) - (warn 'clsql-exists-warning :old-db old-db :new-db old-db)) - (:old - (setq result old-db))) - (setq result - (database-connect connection-spec database-type))) - (when result - (pushnew result *connected-databases*) - (setq *default-database* result) - result)))) - - -(defun disconnect (&key (database *default-database*)) - "Closes the connection to database. Resets *default-database* if that -database was disconnected and only one other connection exists. -if the database is from a pool it will be released to this pool." - (if (conn-pool database) - (release-to-pool database) - (when (database-disconnect database) - (setq *connected-databases* (delete database *connected-databases*)) - (when (eq database *default-database*) - (setq *default-database* (car *connected-databases*))) - (change-class database 'closed-database) - t))) - -;;; Basic operations on databases - -(defmethod query (query-expression &key (database *default-database*) - types) - "Execute the SQL query expression query-expression on the given database. -Returns a list of lists of values of the result of that expression." - (database-query query-expression database types)) - - - -(defmethod execute-command (sql-expression &key (database *default-database*)) - "Execute the SQL command expression sql-expression on the given database. -Returns true on success or nil on failure." - (database-execute-command sql-expression database)) - - - -(defun map-query (output-type-spec function query-expression - &key (database *default-database*) - (types nil)) - "Map the function over all tuples that are returned by the query in -query-expression. The results of the function are collected as -specified in output-type-spec and returned like in MAP." - ;; DANGER Will Robinson: Parts of the code for implementing - ;; map-query (including the code below and the helper functions - ;; called) are highly CMU CL specific. - ;; KMR -- these have been replaced with cross-platform instructions above - (macrolet ((type-specifier-atom (type) - `(if (atom ,type) ,type (car ,type)))) - (case (type-specifier-atom output-type-spec) - ((nil) - (map-query-for-effect function query-expression database types)) - (list - (map-query-to-list function query-expression database types)) - ((simple-vector simple-string vector string array simple-array - bit-vector simple-bit-vector base-string - simple-base-string) - (map-query-to-simple output-type-spec function query-expression database types)) - (t - (funcall #'map-query (cmucl-compat:result-type-or-lose output-type-spec t) - function query-expression :database database :types types))))) - -(defun map-query-for-effect (function query-expression database types) - (multiple-value-bind (result-set columns) - (database-query-result-set query-expression database :full-set nil - :types types) - (when result-set - (unwind-protect - (do ((row (make-list columns))) - ((not (database-store-next-row result-set database row)) - nil) - (apply function row)) - (database-dump-result-set result-set database))))) - -(defun map-query-to-list (function query-expression database types) - (multiple-value-bind (result-set columns) - (database-query-result-set query-expression database :full-set nil - :types types) - (when result-set - (unwind-protect - (let ((result (list nil))) - (do ((row (make-list columns)) - (current-cons result (cdr current-cons))) - ((not (database-store-next-row result-set database row)) - (cdr result)) - (rplacd current-cons (list (apply function row))))) - (database-dump-result-set result-set database))))) - - -(defun map-query-to-simple (output-type-spec function query-expression database types) - (multiple-value-bind (result-set columns rows) - (database-query-result-set query-expression database :full-set t - :types types) - (when result-set - (unwind-protect - (if rows - ;; We know the row count in advance, so we allocate once - (do ((result - (cmucl-compat:make-sequence-of-type output-type-spec rows)) - (row (make-list columns)) - (index 0 (1+ index))) - ((not (database-store-next-row result-set database row)) - result) - (declare (fixnum index)) - (setf (aref result index) - (apply function row))) - ;; Database can't report row count in advance, so we have - ;; to grow and shrink our vector dynamically - (do ((result - (cmucl-compat:make-sequence-of-type output-type-spec 100)) - (allocated-length 100) - (row (make-list columns)) - (index 0 (1+ index))) - ((not (database-store-next-row result-set database row)) - (cmucl-compat:shrink-vector result index)) - (declare (fixnum allocated-length index)) - (when (>= index allocated-length) - (setq allocated-length (* allocated-length 2) - result (adjust-array result allocated-length))) - (setf (aref result index) - (apply function row)))) - (database-dump-result-set result-set database))))) - -(defmacro do-query (((&rest args) query-expression - &key (database '*default-database*) - (types nil)) - &body body) - (let ((result-set (gensym)) - (columns (gensym)) - (row (gensym)) - (db (gensym))) - `(let ((,db ,database)) - (multiple-value-bind (,result-set ,columns) - (database-query-result-set ,query-expression ,db - :full-set nil :types ,types) - (when ,result-set - (unwind-protect - (do ((,row (make-list ,columns))) - ((not (database-store-next-row ,result-set ,db ,row)) - nil) - (destructuring-bind ,args ,row - ,@body)) - (database-dump-result-set ,result-set ,db))))))) - -;;; Marc Battyani : Large objects support - -(defun create-large-object (&key (database *default-database*)) - "Creates a new large object in the database and returns the object identifier" - (database-create-large-object database)) - -(defun write-large-object (object-id data &key (database *default-database*)) - "Writes data to the large object" - (database-write-large-object object-id data database)) - -(defun read-large-object (object-id &key (database *default-database*)) - "Reads the large object content" - (database-read-large-object object-id database)) - -(defun delete-large-object (object-id &key (database *default-database*)) - "Deletes the large object in the database" - (database-delete-large-object object-id database)) diff --git a/clsql/transactions.cl b/clsql/transactions.cl deleted file mode 100644 index a7776ec..0000000 --- a/clsql/transactions.cl +++ /dev/null @@ -1,85 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: transactions.cl -;;;; Purpose: Transaction support -;;;; Programmers: Marc Battyani -;;;; Date Started: Apr 2002 -;;;; -;;;; $Id: transactions.cl,v 1.1 2002/08/01 03:06:26 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-sys) - -;; I removed the USQL transaction stuff to put a smaller, lighter one (MB) - -(defclass transaction () - ((commit-hooks :initform () :accessor commit-hooks) - (rollback-hooks :initform () :accessor rollback-hooks) - (status :initform nil :accessor status))) ;can be nil :rolled-back or :commited - -(defmethod database-start-transaction ((database closed-database)) - (error 'clsql-closed-database-error database)) - -(defmethod database-start-transaction (database) - (unless (transaction database) - (setf (transaction database) (make-instance 'transaction))) - (when (= (incf (transaction-level database)) 1) - (let ((transaction (transaction database))) - (setf (commit-hooks transaction) nil - (rollback-hooks transaction) nil - (status transaction) nil) - (execute-command "BEGIN" :database database)))) - -(defmethod database-end-transaction ((database closed-database)) - (error 'clsql-closed-database-error database)) - -(defmethod database-end-transaction (database) - (if (> (transaction-level database) 0) - (when (zerop (decf (transaction-level database))) - (let ((transaction (transaction database))) - (if (eq (status transaction) :commited) - (progn - (execute-command "COMMIT" :database database) - (map nil #'funcall (commit-hooks transaction))) - (unwind-protect ;status is not :commited - (execute-command "ROLLBACK" :database database) - (map nil #'funcall (rollback-hooks transaction)))))) - (warn "Continue without commit." - 'clsql-simple-error - :format-control "Cannot commit transaction against ~A because there is no transaction in progress." - :format-arguments (list database)))) - -(defun rollback-transaction (database) - (when (and (transaction database)(not (status (transaction database)))) - (setf (status (transaction database)) :rolled-back))) - -(defun commit-transaction (database) - (when (and (transaction database)(not (status (transaction database)))) - (setf (status (transaction database)) :commited))) - -(defun add-transaction-commit-hook (database commit-hook) - (when (transaction database) - (push commit-hook (commit-hooks (transaction database))))) - -(defun add-transaction-rollback-hook (database rollback-hook) - (when (transaction database) - (push rollback-hook (rollback-hooks (transaction database))))) - -(defmacro with-transaction ((&key (database '*default-database*)) &rest body) - (let ((db (gensym "db-"))) - `(let ((,db ,database)) - (unwind-protect - (progn - (database-start-transaction ,db) - ,@body - (commit-transaction ,db)) - (database-end-transaction ,db))))) diff --git a/clsql/usql.cl b/clsql/usql.cl deleted file mode 100644 index 0ccdece..0000000 --- a/clsql/usql.cl +++ /dev/null @@ -1,57 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: usql.cl -;;;; Purpose: High-level interface to SQL driver routines needed for -;;;; UncommonSQL -;;;; Programmers: Kevin M. Rosenberg and onShore Development Inc -;;;; Date Started: Mar 2002 -;;;; -;;;; $Id: usql.cl,v 1.1 2002/08/01 03:06:26 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; and 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. -;;;; ************************************************************************* - - -;;; Minimal high-level routines to enable low-level interface for USQL - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-sys) - -(defun list-tables (&key (database *default-database*) - (system-tables nil)) - "List all tables in *default-database*, or if the :database keyword arg -is given, the specified database. If the keyword arg :system-tables -is true, then it will not filter out non-user tables. Table names are -given back as a list of strings." - (database-list-tables database :system-tables system-tables)) - - -(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/set-logical.cl b/set-logical.cl deleted file mode 100644 index e14fa1c..0000000 --- a/set-logical.cl +++ /dev/null @@ -1,90 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: set-logical.cl -;;;; Purpose: Sets a logical host for src/binaries based on a pathname. -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Feb 2002 -;;;; -;;;; 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. -;;;; ************************************************************************* - - -;;; Setup logical pathname translaton with separate binary directories -;;; for each implementation - -;; push allegro case sensitivity on *features* -#+allegro -(eval-when (:compile-toplevel :load-toplevel :execute) - (if (or (eq excl:*current-case-mode* :case-sensitive-lower) - (eq excl:*current-case-mode* :case-sensitive-upper)) - (pushnew :case-sensitive cl:*features*) - (pushnew :case-insensitive cl:*features*))) - -(defconstant +set-logical-compiler-name+ - #+(and allegro ics case-sensitive) "acl-modern" - #+(and allegro (not ics) case-sensitive) "acl-modern8" - #+(and allegro ics (not case-sensitive)) "acl-ansi" - #+(and allegro (not ics) (not case-sensitive)) "acl-ansi8" - #+lispworks "lispworks" - #+clisp "clisp" - #+cmu "cmucl" - #+sbcl "sbcl" - #+corman "corman" - #+mcl "mcl" - #+openmcl "openmcl" - #-(or allegro lispworks clisp cmu sbcl corman mcl openmcl) "unknown") - -(defun set-logical-host-for-pathname (host base-pathname) - (setf (logical-pathname-translations host) - `(("ROOT;" ,(make-pathname - :host (pathname-host base-pathname) - :device (pathname-device base-pathname) - :directory (pathname-directory base-pathname))) - ("**;*.cl.*" ,(merge-pathnames - (make-pathname - :name :wild - :type :wild - :directory '(:relative :wild-inferiors)) - base-pathname)) - ("**;*.lisp.*" ,(merge-pathnames - (make-pathname - :name :wild - :type :wild - :directory '(:relative :wild-inferiors)) - base-pathname)) - ("**;*.c.*" ,(merge-pathnames - (make-pathname - :name :wild - :type :wild - :directory '(:relative :wild-inferiors)) - base-pathname)) - ("**;*.h.*" ,(merge-pathnames - (make-pathname - :name :wild - :type :wild - :directory '(:relative :wild-inferiors)) - base-pathname)) - ("**;bin;*.*.*" ,(merge-pathnames - (make-pathname - :name :wild - :type :wild - :directory - (append '(:relative :wild-inferiors - ".bin" #.+set-logical-compiler-name+))) - base-pathname)) - ;; default is to place in .bin/ directory - ("**;*.*.*" ,(merge-pathnames - (make-pathname - :name :wild - :type :wild - :directory - (append '(:relative :wild-inferiors - ".bin" #.+set-logical-compiler-name+))) - base-pathname))))) - diff --git a/sql/.cvsignore b/sql/.cvsignore new file mode 100755 index 0000000..ca8d09f --- /dev/null +++ b/sql/.cvsignore @@ -0,0 +1 @@ +.bin diff --git a/sql/Makefile b/sql/Makefile new file mode 100644 index 0000000..31dc910 --- /dev/null +++ b/sql/Makefile @@ -0,0 +1,6 @@ +SUBDIRS := + +include ../Makefile.common + +.PHONY: distclean +distclean: clean diff --git a/sql/functional.cl b/sql/functional.cl new file mode 100644 index 0000000..e283e5d --- /dev/null +++ b/sql/functional.cl @@ -0,0 +1,99 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: functional.cl +;;;; Purpose: Functional interface +;;;; Programmer: Pierre R. Mai +;;;; +;;;; Copyright (c) 1999-2001 Pierre R. Mai +;;;; +;;;; $Id: functional.cl,v 1.8 2002/09/17 17:16:43 kevin Exp $ +;;;; +;;;; This file is part of CLSQL. +;;;; +;;;; CLSQL is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License (version 2) as +;;;; published by the Free Software Foundation. +;;;; +;;;; CLSQL is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with CLSQL; if not, write to the Free Software Foundation, Inc., +;;;; 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :clsql-sys) + + +;;;; This file implements the more advanced functions of the +;;;; functional SQL interface, which are just nicer layers above the +;;;; basic SQL interface. + +(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)))) + +(defmacro with-database ((db-var connection-spec &rest connect-args) &body body) + "Evaluate the body in an environment, where `db-var' is bound to the +database connection given by `connection-spec' and `connect-args'. +The connection is automatically closed or released to the pool on exit from the body." + (let ((result (gensym "result-"))) + (unless db-var (setf db-var '*default-database*)) + `(let ((,db-var (connect ,connection-spec ,@connect-args)) + (,result nil)) + (unwind-protect + (let ((,db-var ,db-var)) + (setf ,result (progn ,@body))) + (disconnect :database ,db-var)) + ,result))) \ No newline at end of file diff --git a/sql/loop-extension.cl b/sql/loop-extension.cl new file mode 100644 index 0000000..6b59250 --- /dev/null +++ b/sql/loop-extension.cl @@ -0,0 +1,98 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: loop-extension.cl +;;;; Purpose: Extensions to the Loop macro for CMUCL +;;;; Programmer: Pierre R. Mai +;;;; +;;;; Copyright (c) 1999-2001 Pierre R. Mai +;;;; +;;;; $Id: loop-extension.cl,v 1.3 2002/09/17 17:16:43 kevin Exp $ +;;;; +;;;; The functions in this file were orignally distributed in the +;;;; MaiSQL package in the file sql/sql.cl +;;;; ************************************************************************* + +(in-package :cl-user) + +;;;; MIT-LOOP extension + +#+cmu +(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 '(*default-database*))) + (cond + ((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 + (database-dump-result-set ,result-set-var ,db-var)) + ansi-loop::*loop-epilogue*) + `(((,variable nil ,data-type) (,query-var ,(first in-phrase)) + (,db-var ,(first from-phrase)) + (,result-set-var nil) + (,step-var nil)) + ((multiple-value-bind (%rs %cols) + (database-query-result-set ,query-var ,db-var) + (setq ,result-set-var %rs ,step-var (make-list %cols)))) + () + () + (not (database-store-next-row ,result-set-var ,db-var ,step-var)) + (,variable ,step-var) + (not ,result-set-var) + () + (not (database-store-next-row ,result-set-var ,db-var ,step-var)) + (,variable ,step-var)))) + (t + (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-))) + (push `(when ,result-set-var + (database-dump-result-set ,result-set-var ,db-var)) + ansi-loop::*loop-epilogue*) + `(((,variable nil ,data-type) (,query-var ,(first in-phrase)) + (,db-var ,(first from-phrase)) + (,result-set-var nil)) + ((multiple-value-bind (%rs %cols) + (database-query-result-set ,query-var ,db-var) + (setq ,result-set-var %rs ,variable (make-list %cols)))) + () + () + (not (database-store-next-row ,result-set-var ,db-var ,variable)) + () + (not ,result-set-var) + () + (not (database-store-next-row ,result-set-var ,db-var ,variable)) + ())))))) + +#+cmu +(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) diff --git a/sql/package.cl b/sql/package.cl new file mode 100644 index 0000000..2bb0d8e --- /dev/null +++ b/sql/package.cl @@ -0,0 +1,133 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: package.cl +;;;; Purpose: Package definition for CLSQL (high-level) interface +;;;; Programmers: Kevin M. Rosenberg based on +;;;; Original code by Pierre R. Mai +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: package.cl,v 1.19 2002/09/17 17:16:43 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 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. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :cl-user) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defpackage :clsql-sys + (:nicknames :clsql) + (:use :common-lisp :clsql-base-sys) + (: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-connect-error + #:clsql-connect-error-database-type + #:clsql-connect-error-connection-spec + #:clsql-connect-error-errno + #:clsql-connect-error-error + #:clsql-sql-error + #:clsql-sql-error-database + #:clsql-sql-error-expression + #:clsql-sql-error-errno + #:clsql-sql-error-error + #:clsql-database-warning + #:clsql-database-warning-database + #:clsql-database-warning-message + #:clsql-exists-condition + #:clsql-exists-condition-new-db + #:clsql-exists-condition-old-db + #:clsql-exists-warning + #:clsql-exists-error + #:clsql-closed-error + #:clsql-closed-error-database + + #:*loaded-database-types* + #:reload-database-types + #:*default-database-type* + #:*initialized-database-types* + #:initialize-database-type + + #:database + #:database-name + #:closed-database + #:database-name-from-spec + + ;; utils.cl + #:number-to-sql-string + #:float-to-sql-string + #:sql-escape-quotes + )) + (:export + ;; sql.cl + #:*connect-if-exists* + #:connected-databases + #:*default-database* + #:find-database + #:connect + #:disconnect + #:query + #:execute-command + #:map-query + #:do-query + + ;; functional.cl + #:insert-records + #:delete-records + #:update-records + #:with-database + + ;; For High-level UncommonSQL compatibility + #:sql-ident + #:list-tables + #:list-attributes + #:attribute-type + #:create-sequence + #:drop-sequence + #:sequence-next + + ;; Pooled connections + #:disconnect-pooled + #:find-or-create-connection-pool + + ;; Transactions + #:with-transaction + #:commit-transaction + #:rollback-transaction + #:add-transaction-commit-hook + #:add-transaction-rollback-hook + + ;; Large objects (Marc B) + #:create-large-object + #:write-large-object + #:read-large-object + #:delete-large-object + + . + #1# + ) + (:documentation "This is the INTERNAL SQL-Interface package of CLSQL.")) + + ) ;eval-when + +(defpackage #:clsql-user + (:use #:common-lisp #:clsql) + (:documentation "This is the user package for experimenting with CLSQL.")) diff --git a/sql/pool.cl b/sql/pool.cl new file mode 100644 index 0000000..f4d965c --- /dev/null +++ b/sql/pool.cl @@ -0,0 +1,79 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: pool.cl +;;;; Purpose: Support function for connection pool +;;;; Programmers: Kevin M. Rosenberg, Marc Battyani +;;;; Date Started: Apr 2002 +;;;; +;;;; $Id: pool.cl,v 1.8 2002/09/17 17:16:43 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :clsql-sys) + +(defvar *db-pool* (make-hash-table :test #'equal)) + +(defclass conn-pool () + ((connection-spec :accessor connection-spec :initarg :connection-spec) + (database-type :accessor database-type :initarg :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)))) + +(defun acquire-from-conn-pool (pool) + (if (zerop (length (free-connections pool))) + (let ((conn (connect (connection-spec pool) + :database-type (database-type pool) :if-exists :new))) + (vector-push-extend conn (all-connections pool)) + (setf (conn-pool conn) pool) + conn) + (vector-pop (free-connections pool)))) + +(defun release-to-conn-pool (conn) + (vector-push-extend conn (free-connections (conn-pool conn)))) + +(defun clear-conn-pool (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)) + +(defun find-or-create-connection-pool (connection-spec database-type) + "Find connection pool in hash table, creates a new connection pool if not found" + (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 + :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" + (maphash + #'(lambda (key conn-pool) + (declare (ignore key)) + (clear-conn-pool conn-pool)) + *db-pool*) + (when clear (clrhash *db-pool*)) + t) + diff --git a/sql/sql.cl b/sql/sql.cl new file mode 100644 index 0000000..101d30f --- /dev/null +++ b/sql/sql.cl @@ -0,0 +1,262 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: sql.cl +;;;; Purpose: High-level SQL interface +;;;; Programmers: Kevin M. Rosenberg based on +;;;; Original code by Pierre R. Mai +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: sql.cl,v 1.19 2002/09/17 17:16:43 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 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. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :clsql-sys) + +;;; Modified by KMR +;;; - to use CMUCL-COMPAT library +;;; - fix format strings in error messages +;;; - use field types + + +;;; Simple implementation of SQL along the lines of Harlequin's Common SQL + + +;;; Database handling + +(defvar *connect-if-exists* :error + "Default value for the if-exists parameter of connect calls.") + +(defvar *connected-databases* nil + "List of active database objects.") + +(defun connected-databases () + "Return the list of active database objects." + *connected-databases*) + +(defvar *default-database* nil + "Specifies the default database to be used.") + +(defun find-database (database &optional (errorp t)) + (etypecase database + (database + ;; Return the database object itself + database) + (string + (or (find database (connected-databases) + :key #'database-name + :test #'string=) + (when errorp + (cerror "Return nil." + 'clsql-simple-error + :format-control "There exists no database called ~A." + :format-arguments (list database))))))) + +(defun connect (connection-spec + &key (if-exists *connect-if-exists*) + (database-type *default-database-type*) + (pool nil)) + "Connects to a database of the given database-type, using the type-specific +connection-spec. if-exists is currently ignored. +If pool is t the the connection will be taken from the general pool, +if pool is a conn-pool object the connection will be taken from this pool. +" + (if pool + (acquire-from-pool connection-spec database-type pool) + (let* ((db-name (database-name-from-spec connection-spec database-type)) + (old-db (unless (eq if-exists :new) (find-database db-name nil))) + (result nil)) + (if old-db + (case if-exists +; (:new +; (setq result +; (database-connect connection-spec database-type))) + (:warn-new + (setq result + (database-connect connection-spec database-type)) + (warn 'clsql-exists-warning :old-db old-db :new-db result)) + (:error + (restart-case + (error 'clsql-exists-error :old-db old-db) + (create-new () + :report "Create a new connection." + (setq result + (database-connect connection-spec database-type))) + (use-old () + :report "Use the existing connection." + (setq result old-db)))) + (:warn-old + (setq result old-db) + (warn 'clsql-exists-warning :old-db old-db :new-db old-db)) + (:old + (setq result old-db))) + (setq result + (database-connect connection-spec database-type))) + (when result + (pushnew result *connected-databases*) + (setq *default-database* result) + result)))) + + +(defun disconnect (&key (database *default-database*)) + "Closes the connection to database. Resets *default-database* if that +database was disconnected and only one other connection exists. +if the database is from a pool it will be released to this pool." + (if (conn-pool database) + (release-to-pool database) + (when (database-disconnect database) + (setq *connected-databases* (delete database *connected-databases*)) + (when (eq database *default-database*) + (setq *default-database* (car *connected-databases*))) + (change-class database 'closed-database) + t))) + +;;; Basic operations on databases + +(defmethod query (query-expression &key (database *default-database*) + types) + "Execute the SQL query expression query-expression on the given database. +Returns a list of lists of values of the result of that expression." + (database-query query-expression database types)) + + + +(defmethod execute-command (sql-expression &key (database *default-database*)) + "Execute the SQL command expression sql-expression on the given database. +Returns true on success or nil on failure." + (database-execute-command sql-expression database)) + + + +(defun map-query (output-type-spec function query-expression + &key (database *default-database*) + (types nil)) + "Map the function over all tuples that are returned by the query in +query-expression. The results of the function are collected as +specified in output-type-spec and returned like in MAP." + ;; DANGER Will Robinson: Parts of the code for implementing + ;; map-query (including the code below and the helper functions + ;; called) are highly CMU CL specific. + ;; KMR -- these have been replaced with cross-platform instructions above + (macrolet ((type-specifier-atom (type) + `(if (atom ,type) ,type (car ,type)))) + (case (type-specifier-atom output-type-spec) + ((nil) + (map-query-for-effect function query-expression database types)) + (list + (map-query-to-list function query-expression database types)) + ((simple-vector simple-string vector string array simple-array + bit-vector simple-bit-vector base-string + simple-base-string) + (map-query-to-simple output-type-spec function query-expression database types)) + (t + (funcall #'map-query (cmucl-compat:result-type-or-lose output-type-spec t) + function query-expression :database database :types types))))) + +(defun map-query-for-effect (function query-expression database types) + (multiple-value-bind (result-set columns) + (database-query-result-set query-expression database :full-set nil + :types types) + (when result-set + (unwind-protect + (do ((row (make-list columns))) + ((not (database-store-next-row result-set database row)) + nil) + (apply function row)) + (database-dump-result-set result-set database))))) + +(defun map-query-to-list (function query-expression database types) + (multiple-value-bind (result-set columns) + (database-query-result-set query-expression database :full-set nil + :types types) + (when result-set + (unwind-protect + (let ((result (list nil))) + (do ((row (make-list columns)) + (current-cons result (cdr current-cons))) + ((not (database-store-next-row result-set database row)) + (cdr result)) + (rplacd current-cons (list (apply function row))))) + (database-dump-result-set result-set database))))) + + +(defun map-query-to-simple (output-type-spec function query-expression database types) + (multiple-value-bind (result-set columns rows) + (database-query-result-set query-expression database :full-set t + :types types) + (when result-set + (unwind-protect + (if rows + ;; We know the row count in advance, so we allocate once + (do ((result + (cmucl-compat:make-sequence-of-type output-type-spec rows)) + (row (make-list columns)) + (index 0 (1+ index))) + ((not (database-store-next-row result-set database row)) + result) + (declare (fixnum index)) + (setf (aref result index) + (apply function row))) + ;; Database can't report row count in advance, so we have + ;; to grow and shrink our vector dynamically + (do ((result + (cmucl-compat:make-sequence-of-type output-type-spec 100)) + (allocated-length 100) + (row (make-list columns)) + (index 0 (1+ index))) + ((not (database-store-next-row result-set database row)) + (cmucl-compat:shrink-vector result index)) + (declare (fixnum allocated-length index)) + (when (>= index allocated-length) + (setq allocated-length (* allocated-length 2) + result (adjust-array result allocated-length))) + (setf (aref result index) + (apply function row)))) + (database-dump-result-set result-set database))))) + +(defmacro do-query (((&rest args) query-expression + &key (database '*default-database*) + (types nil)) + &body body) + (let ((result-set (gensym)) + (columns (gensym)) + (row (gensym)) + (db (gensym))) + `(let ((,db ,database)) + (multiple-value-bind (,result-set ,columns) + (database-query-result-set ,query-expression ,db + :full-set nil :types ,types) + (when ,result-set + (unwind-protect + (do ((,row (make-list ,columns))) + ((not (database-store-next-row ,result-set ,db ,row)) + nil) + (destructuring-bind ,args ,row + ,@body)) + (database-dump-result-set ,result-set ,db))))))) + +;;; Marc Battyani : Large objects support + +(defun create-large-object (&key (database *default-database*)) + "Creates a new large object in the database and returns the object identifier" + (database-create-large-object database)) + +(defun write-large-object (object-id data &key (database *default-database*)) + "Writes data to the large object" + (database-write-large-object object-id data database)) + +(defun read-large-object (object-id &key (database *default-database*)) + "Reads the large object content" + (database-read-large-object object-id database)) + +(defun delete-large-object (object-id &key (database *default-database*)) + "Deletes the large object in the database" + (database-delete-large-object object-id database)) diff --git a/sql/transactions.cl b/sql/transactions.cl new file mode 100644 index 0000000..c95e8c3 --- /dev/null +++ b/sql/transactions.cl @@ -0,0 +1,85 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: transactions.cl +;;;; Purpose: Transaction support +;;;; Programmers: Marc Battyani +;;;; Date Started: Apr 2002 +;;;; +;;;; $Id: transactions.cl,v 1.7 2002/09/17 17:16:43 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :clsql-sys) + +;; I removed the USQL transaction stuff to put a smaller, lighter one (MB) + +(defclass transaction () + ((commit-hooks :initform () :accessor commit-hooks) + (rollback-hooks :initform () :accessor rollback-hooks) + (status :initform nil :accessor status))) ;can be nil :rolled-back or :commited + +(defmethod database-start-transaction ((database closed-database)) + (error 'clsql-closed-database-error database)) + +(defmethod database-start-transaction (database) + (unless (transaction database) + (setf (transaction database) (make-instance 'transaction))) + (when (= (incf (transaction-level database)) 1) + (let ((transaction (transaction database))) + (setf (commit-hooks transaction) nil + (rollback-hooks transaction) nil + (status transaction) nil) + (execute-command "BEGIN" :database database)))) + +(defmethod database-end-transaction ((database closed-database)) + (error 'clsql-closed-database-error database)) + +(defmethod database-end-transaction (database) + (if (> (transaction-level database) 0) + (when (zerop (decf (transaction-level database))) + (let ((transaction (transaction database))) + (if (eq (status transaction) :commited) + (progn + (execute-command "COMMIT" :database database) + (map nil #'funcall (commit-hooks transaction))) + (unwind-protect ;status is not :commited + (execute-command "ROLLBACK" :database database) + (map nil #'funcall (rollback-hooks transaction)))))) + (warn "Continue without commit." + 'clsql-simple-error + :format-control "Cannot commit transaction against ~A because there is no transaction in progress." + :format-arguments (list database)))) + +(defun rollback-transaction (database) + (when (and (transaction database)(not (status (transaction database)))) + (setf (status (transaction database)) :rolled-back))) + +(defun commit-transaction (database) + (when (and (transaction database)(not (status (transaction database)))) + (setf (status (transaction database)) :commited))) + +(defun add-transaction-commit-hook (database commit-hook) + (when (transaction database) + (push commit-hook (commit-hooks (transaction database))))) + +(defun add-transaction-rollback-hook (database rollback-hook) + (when (transaction database) + (push rollback-hook (rollback-hooks (transaction database))))) + +(defmacro with-transaction ((&key (database '*default-database*)) &rest body) + (let ((db (gensym "db-"))) + `(let ((,db ,database)) + (unwind-protect + (progn + (database-start-transaction ,db) + ,@body + (commit-transaction ,db)) + (database-end-transaction ,db))))) diff --git a/sql/usql.cl b/sql/usql.cl new file mode 100644 index 0000000..1141dc0 --- /dev/null +++ b/sql/usql.cl @@ -0,0 +1,57 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: usql.cl +;;;; Purpose: High-level interface to SQL driver routines needed for +;;;; UncommonSQL +;;;; Programmers: Kevin M. Rosenberg and onShore Development Inc +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id: usql.cl,v 1.11 2002/09/17 17:16:43 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; and 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. +;;;; ************************************************************************* + + +;;; Minimal high-level routines to enable low-level interface for USQL + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :clsql-sys) + +(defun list-tables (&key (database *default-database*) + (system-tables nil)) + "List all tables in *default-database*, or if the :database keyword arg +is given, the specified database. If the keyword arg :system-tables +is true, then it will not filter out non-user tables. Table names are +given back as a list of strings." + (database-list-tables database :system-tables system-tables)) + + +(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)) + +