--- /dev/null
+SUBDIRS :=
+
+include ../Makefile.common
+
+.PHONY: distclean
+distclean: clean
--- /dev/null
+;;;; -*- 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)
+ "<unbound>")
+ 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)
+ "<unbound>")
+ stream)))
+
--- /dev/null
+;;;; -*- 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))
--- /dev/null
+;;;; -*- 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))
+
--- /dev/null
+;;;; -*- 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"))
--- /dev/null
+;;;; -*- 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)))
+
+
--- /dev/null
+;;;; -*- 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
+
+
--- /dev/null
+;;;; -*- 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)))
+
+
;;;; 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
;;;;
;;;; (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")
+++ /dev/null
-;;;; -*- 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))
-
-
;;;; 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
;;;;
;;;; (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))))
+++ /dev/null
-;;;; -*- 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*)
- )
+++ /dev/null
-SUBDIRS :=
-
-include ../Makefile.common
-
-.PHONY: distclean
-distclean: clean
+++ /dev/null
-;;;; -*- 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)
- "<unbound>")
- 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)
- "<unbound>")
- stream)))
-
+++ /dev/null
-;;;; -*- 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))
+++ /dev/null
-;;;; -*- 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))
-
+++ /dev/null
-;;;; -*- 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"))
+++ /dev/null
-;;;; -*- 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)))
-
-
+++ /dev/null
-;;;; -*- 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
-
-
+++ /dev/null
-;;;; -*- 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)))
-
-
;;;; Programmer: Kevin M. Rosenberg\r
;;;; Date Started: Aug 2002\r
;;;;\r
-;;;; $Id: clsql-mysql.asd,v 1.5 2002/09/06 10:56:13 kevin Exp $\r
+;;;; $Id: clsql-mysql.asd,v 1.6 2002/09/17 17:16:43 kevin Exp $\r
;;;;\r
;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg\r
;;;;\r
\r
;;; System definition\r
\r
-(defsystem clsql-mysql\r
- :pathname #.(format nil "~A:clsql-mysql;"\r
- #+common-lisp-controller "cl-library"\r
- #-common-lisp-controller "clsql")\r
- :components ((:file "mysql-package")\r
- (:file "mysql-loader" :depends-on ("mysql-package"))\r
- (:file "mysql-api" :depends-on ("mysql-loader"))\r
- (:file "mysql-sql" :depends-on ("mysql-api"))\r
- (:file "mysql-usql" :depends-on ("mysql-sql")))\r
- :depends-on (:uffi :clsql-base :clsql-uffi))\r
-\r
-\r
+(defsystem :clsql-mysql\r
+ :components\r
+ ((:module :mysql\r
+ :components\r
+ ((:file "mysql-package")\r
+ (:file "mysql-loader" :depends-on ("mysql-package"))\r
+ (:file "mysql-api" :depends-on ("mysql-loader"))\r
+ (:file "mysql-sql" :depends-on ("mysql-api"))\r
+ (:file "mysql-usql" :depends-on ("mysql-sql")))))\r
+ :depends-on (:uffi :clsql-base :clsql-uffi))\r
+ \r
(defmethod source-file-type ((c cl-source-file)\r
(s (eql (find-system 'clsql-mysql)))) \r
"cl")\r
-\r
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-\r
-;;;; *************************************************************************\r
-;;;; FILE IDENTIFICATION\r
-;;;;\r
-;;;; Name: clsql-mysql.system\r
-;;;; Purpose: Defsystem-3/4 definition file for CLSQL MySQL backend\r
-;;;; Programmer: Kevin M. Rosenberg\r
-;;;; Date Started: Feb 2002\r
-;;;;\r
-;;;; $Id: clsql-mysql.system,v 1.18 2002/09/06 10:56:13 kevin Exp $\r
-;;;;\r
-;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg\r
-;;;;\r
-;;;; CLSQL users are granted the rights to distribute and use this software\r
-;;;; as governed by the terms of the Lisp Lesser GNU Public License\r
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.\r
-;;;; *************************************************************************\r
-\r
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))\r
-\r
-(in-package :make)\r
-\r
-;;; System definition\r
-\r
-(defsystem :clsql-mysql\r
- :source-pathname #.(format nil "~A:clsql-mysql;"\r
- #+common-lisp-controller "cl-library"\r
- #-common-lisp-controller "clsql")\r
- :source-extension "cl"\r
- :components ((:file "mysql-package")\r
- (:file "mysql-loader" :depends-on ("mysql-package"))\r
- (:file "mysql-api" :depends-on ("mysql-loader"))\r
- (:file "mysql-sql" :depends-on ("mysql-api"))\r
- (:file "mysql-usql" :depends-on ("mysql-sql")))\r
- :depends-on (:uffi :clsql-base :clsql-uffi))\r
-\r
-\r
-\r
-\r
-\r
;;;; -*- 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")
+++ /dev/null
-;;;; -*- 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))
-
-
-
-
;;;; Programmer: Kevin M. Rosenberg\r
;;;; Date Started: Aug 2002\r
;;;;\r
-;;;; $Id: clsql-postgresql-socket.asd,v 1.5 2002/09/06 10:56:13 kevin Exp $\r
+;;;; $Id: clsql-postgresql-socket.asd,v 1.6 2002/09/17 17:16:43 kevin Exp $\r
;;;;\r
;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg\r
;;;;\r
;;; System definition\r
\r
(defsystem clsql-postgresql-socket\r
- :pathname #.(format nil "~A:clsql-postgresql-socket;"\r
- #+common-lisp-controller "cl-library"\r
- #-common-lisp-controller "clsql")\r
- :components ((:file "postgresql-socket-package")\r
- (:file "postgresql-socket-api"\r
- :depends-on ("postgresql-socket-package"))\r
- (:file "postgresql-socket-sql"\r
- :depends-on ("postgresql-socket-api")))\r
- :depends-on (:clsql-base :uffi))\r
+ :components\r
+ ((:module :clsql-postgresql-socket\r
+ :components\r
+ ((:file "postgresql-socket-package")\r
+ (:file "postgresql-socket-api"\r
+ :depends-on ("postgresql-socket-package"))\r
+ (:file "postgresql-socket-sql"\r
+ :depends-on ("postgresql-socket-api")))))\r
+ :depends-on (:clsql-base :uffi))\r
\r
(defmethod source-file-type ((c cl-source-file)\r
(s (eql (find-system 'clsql-postgresql-socket)))) \r
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-\r
-;;;; *************************************************************************\r
-;;;; FILE IDENTIFICATION\r
-;;;;\r
-;;;; Name: clsql-postgresql.system\r
-;;;; Purpose: Defsystem-3/4 file for CLSQL PostgresSQL socket backend\r
-;;;; Programmer: Kevin M. Rosenberg\r
-;;;; Date Started: Feb 2002\r
-;;;;\r
-;;;; $Id: clsql-postgresql-socket.system,v 1.12 2002/09/06 10:56:13 kevin Exp $\r
-;;;;\r
-;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg\r
-;;;;\r
-;;;; CLSQL users are granted the rights to distribute and use this software\r
-;;;; as governed by the terms of the Lisp Lesser GNU Public License\r
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.\r
-;;;; *************************************************************************\r
-\r
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))\r
-(in-package :make)\r
-\r
-;;; System definition\r
-\r
-(defsystem :clsql-postgresql-socket\r
- :source-pathname #.(format nil "~A:clsql-postgresql-socket;"\r
- #+common-lisp-controller "cl-library"\r
- #-common-lisp-controller "clsql")\r
- :source-extension "cl"\r
- :components ((:file "postgresql-socket-package")\r
- (:file "postgresql-socket-api"\r
- :depends-on ("postgresql-socket-package"))\r
- (:file "postgresql-socket-sql"\r
- :depends-on ("postgresql-socket-api")))\r
- :depends-on (:clsql-base :uffi))\r
;;;; Programmer: Kevin M. Rosenberg\r
;;;; Date Started: Aug 2002\r
;;;;\r
-;;;; $Id: clsql-postgresql.asd,v 1.5 2002/09/06 10:56:13 kevin Exp $\r
+;;;; $Id: clsql-postgresql.asd,v 1.6 2002/09/17 17:16:43 kevin Exp $\r
;;;;\r
;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg\r
;;;;\r
(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))\r
(in-package :asdf)\r
\r
-(defsystem clsql-postgresql\r
- :pathname #.(format nil "~A:clsql-postgresql;"\r
- #+common-lisp-controller "cl-library"\r
- #-common-lisp-controller "clsql")\r
- :components ((:file "postgresql-package")\r
- (:file "postgresql-loader" :depends-on ("postgresql-package"))\r
- (:file "postgresql-api" :depends-on ("postgresql-loader"))\r
- (:file "postgresql-sql" :depends-on ("postgresql-api"))\r
- (:file "postgresql-usql" :depends-on ("postgresql-sql")))\r
- :depends-on (:uffi :clsql-base :clsql-uffi))\r
-\r
+(defsystem :clsql-postgresql\r
+ :components\r
+ ((:module :clsql-postgresql\r
+ :components\r
+ ((:file "postgresql-package")\r
+ (:file "postgresql-loader" :depends-on ("postgresql-package"))\r
+ (:file "postgresql-api" :depends-on ("postgresql-loader"))\r
+ (:file "postgresql-sql" :depends-on ("postgresql-api"))\r
+ (:file "postgresql-usql" :depends-on ("postgresql-sql")))))\r
+ :depends-on (:uffi :clsql-base :clsql-uffi))\r
\r
(defmethod source-file-type ((c cl-source-file)\r
(s (eql (find-system 'clsql-postgresql)))) \r
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-\r
-;;;; *************************************************************************\r
-;;;; FILE IDENTIFICATION\r
-;;;;\r
-;;;; Name: clsql-postgresql.system\r
-;;;; Purpose: Defsystem-3/4 file for CLSQL PostgresSQL backend\r
-;;;; Programmer: Kevin M. Rosenberg\r
-;;;; Date Started: Feb 2002\r
-;;;;\r
-;;;; $Id: clsql-postgresql.system,v 1.12 2002/09/06 10:56:13 kevin Exp $\r
-;;;;\r
-;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg\r
-;;;;\r
-;;;; CLSQL users are granted the rights to distribute and use this software\r
-;;;; as governed by the terms of the Lisp Lesser GNU Public License\r
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.\r
-;;;; *************************************************************************\r
-\r
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))\r
-(in-package :make)\r
-\r
-(defsystem :clsql-postgresql\r
- :source-pathname #.(format nil "~A:clsql-postgresql;"\r
- #+common-lisp-controller "cl-library"\r
- #-common-lisp-controller "clsql")\r
- :source-extension "cl"\r
- :components ((:file "postgresql-package")\r
- (:file "postgresql-loader" :depends-on ("postgresql-package"))\r
- (:file "postgresql-api" :depends-on ("postgresql-loader"))\r
- (:file "postgresql-sql" :depends-on ("postgresql-api"))\r
- (:file "postgresql-usql" :depends-on ("postgresql-sql")))\r
- :depends-on (:uffi :clsql-base :clsql-uffi))\r
-\r
;;;; 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
;;;;
;;; 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")
-
+++ /dev/null
-;;;; -*- 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))
-
;;;; 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
;;;;
;;;; (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")
-
+++ /dev/null
-;;;; -*- 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*)
- )
+++ /dev/null
-SUBDIRS :=
-
-include ../Makefile.common
-
-.PHONY: distclean
-distclean: clean
+++ /dev/null
-;;;; -*- 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
+++ /dev/null
-;;;; -*- 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)
+++ /dev/null
-;;;; -*- 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."))
+++ /dev/null
-;;;; -*- 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)
-
+++ /dev/null
-;;;; -*- 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))
+++ /dev/null
-;;;; -*- 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)))))
+++ /dev/null
-;;;; -*- 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))
-
-
+++ /dev/null
-;;;; -*- 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/<compiler> directory
- ("**;*.*.*" ,(merge-pathnames
- (make-pathname
- :name :wild
- :type :wild
- :directory
- (append '(:relative :wild-inferiors
- ".bin" #.+set-logical-compiler-name+)))
- base-pathname)))))
-
--- /dev/null
+SUBDIRS :=
+
+include ../Makefile.common
+
+.PHONY: distclean
+distclean: clean
--- /dev/null
+;;;; -*- 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
--- /dev/null
+;;;; -*- 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)
--- /dev/null
+;;;; -*- 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."))
--- /dev/null
+;;;; -*- 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)
+
--- /dev/null
+;;;; -*- 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))
--- /dev/null
+;;;; -*- 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)))))
--- /dev/null
+;;;; -*- 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))
+
+