From: Kevin M. Rosenberg Date: Mon, 30 Sep 2002 10:19:10 +0000 (+0000) Subject: r2913: *** empty log message *** X-Git-Tag: v3.8.6~916 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=998937376fa6f9ce29bd3c7954fb0ebca91c37d7 r2913: *** empty log message *** --- diff --git a/base/classes.cl b/base/classes.cl deleted file mode 100644 index 26dbf71..0000000 --- a/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.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/classes.lisp b/base/classes.lisp new file mode 100644 index 0000000..aa61ce6 --- /dev/null +++ b/base/classes.lisp @@ -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.lisp,v 1.1 2002/09/30 10:19:01 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 deleted file mode 100644 index 4f65794..0000000 --- a/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.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/cmucl-compat.lisp b/base/cmucl-compat.lisp new file mode 100644 index 0000000..a479bc1 --- /dev/null +++ b/base/cmucl-compat.lisp @@ -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.lisp,v 1.1 2002/09/30 10:19:01 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 deleted file mode 100644 index 2446eb3..0000000 --- a/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.5 2002/09/30 06:13:05 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/conditions.lisp b/base/conditions.lisp new file mode 100644 index 0000000..5f0fb3a --- /dev/null +++ b/base/conditions.lisp @@ -0,0 +1,159 @@ +;;;; -*- 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.lisp,v 1.1 2002/09/30 10:19:01 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 deleted file mode 100644 index 33f3b9c..0000000 --- a/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.6 2002/09/27 15:08:13 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) - (: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 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/db-interface.lisp b/base/db-interface.lisp new file mode 100644 index 0000000..ce1b068 --- /dev/null +++ b/base/db-interface.lisp @@ -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.lisp,v 1.1 2002/09/30 10:19:01 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) + (: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 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 deleted file mode 100644 index 6215376..0000000 --- a/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.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/initialize.lisp b/base/initialize.lisp new file mode 100644 index 0000000..7bb8d1b --- /dev/null +++ b/base/initialize.lisp @@ -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.lisp,v 1.1 2002/09/30 10:19:01 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 deleted file mode 100644 index 8f8fc4a..0000000 --- a/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.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/package.lisp b/base/package.lisp new file mode 100644 index 0000000..18ce31b --- /dev/null +++ b/base/package.lisp @@ -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.lisp,v 1.1 2002/09/30 10:19:01 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 deleted file mode 100644 index 1a34f78..0000000 --- a/base/utils.cl +++ /dev/null @@ -1,78 +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.7 2002/09/30 01:57:32 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" - (let ((str (write-to-string num :readably t))) - (cond - ((find #\f str) - (substitute #\e #\f str)) - ((find #\d str) - (substitute #\e #\d str)) - ((find #\F str) - (substitute #\e #\F str)) - ((find #\D str) - (substitute #\e #\D str)) - ((find #\S str) - (substitute #\e #\S str)) - (t - str)))) - - (defun sql-escape (identifier) - "Change hyphens to underscores, ensure string" - (let* ((unescaped (etypecase identifier - (symbol (symbol-name identifier)) - (string identifier))) - (escaped (make-string (length unescaped)))) - (dotimes (i (length unescaped)) - (setf (char escaped i) - (cond ((equal (char unescaped i) #\-) - #\_) - ;; ... - (t - (char unescaped i))))) - escaped)) - - -(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/base/utils.lisp b/base/utils.lisp new file mode 100644 index 0000000..5514dc7 --- /dev/null +++ b/base/utils.lisp @@ -0,0 +1,78 @@ +;;;; -*- 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.lisp,v 1.1 2002/09/30 10:19:01 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" + (let ((str (write-to-string num :readably t))) + (cond + ((find #\f str) + (substitute #\e #\f str)) + ((find #\d str) + (substitute #\e #\d str)) + ((find #\F str) + (substitute #\e #\F str)) + ((find #\D str) + (substitute #\e #\D str)) + ((find #\S str) + (substitute #\e #\S str)) + (t + str)))) + + (defun sql-escape (identifier) + "Change hyphens to underscores, ensure string" + (let* ((unescaped (etypecase identifier + (symbol (symbol-name identifier)) + (string identifier))) + (escaped (make-string (length unescaped)))) + (dotimes (i (length unescaped)) + (setf (char escaped i) + (cond ((equal (char unescaped i) #\-) + #\_) + ;; ... + (t + (char unescaped i))))) + escaped)) + + +(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))) + +