From 8213ff48f5362c3d4792444c929f50bd128bd044 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sat, 23 Mar 2002 14:04:48 +0000 Subject: [PATCH] r1639: Initial revision --- COPYING.CLSQL | 16 + COPYING.MaiSQL | 25 + ChangeLog | 4 + INSTALL | 5 + Makefile | 55 + NEWS | 1 + README | 11 + TODO | 4 + VERSION | 2 + clsql-aodbc.system | 30 + clsql-mysql.system | 41 + clsql-postgresql-socket.system | 33 + clsql-postgresql.system | 31 + clsql.system | 45 + cmucl-compat/.cvsignore | 1 + cmucl-compat/cmucl-compat.cl | 115 + cmucl-compat/loop-extension.cl | 98 + doc/.cvsignore | 8 + doc/Makefile | 108 + doc/appendix.sgml | 305 +++ doc/bookinfo.sgml | 55 + doc/catalog | 2 + doc/clsql.sgml | 38 + doc/dsssl/html-docbook.dsl | 30 + doc/dsssl/html/docbook.dsl | 30 + doc/dsssl/print-docbook.dsl | 30 + doc/dsssl/print/docbook.dsl | 30 + doc/glossary.sgml | 76 + doc/intro.sgml | 138 + doc/preface.sgml | 15 + doc/ref.sgml | 2392 +++++++++++++++++ doc/sgml-docbook-4.1.cat | 4 + interfaces/aodbc/.cvsignore | 1 + interfaces/aodbc/aodbc-package.cl | 31 + interfaces/aodbc/aodbc-sql.cl | 123 + interfaces/mysql/.cvsignore | 4 + interfaces/mysql/Makefile | 59 + interfaces/mysql/Makefile.msvc | 42 + interfaces/mysql/clsql-mysql.c | 90 + interfaces/mysql/mysql-loader.cl | 69 + interfaces/mysql/mysql-package.cl | 125 + interfaces/mysql/mysql-sql.cl | 191 ++ interfaces/mysql/mysql-uffi.cl | 579 ++++ interfaces/mysql/testing/mysql-struct-size.cc | 7 + interfaces/mysql/testing/mysql-struct-size.cl | 11 + interfaces/postgresql-socket/.cvsignore | 1 + .../postgresql-socket-package.cl | 54 + .../postgresql-socket-sql.cl | 206 ++ .../postgresql-socket-uffi.cl | 676 +++++ interfaces/postgresql/.cvsignore | 1 + interfaces/postgresql/postgresql-loader.cl | 48 + interfaces/postgresql/postgresql-package.cl | 67 + interfaces/postgresql/postgresql-sql.cl | 233 ++ interfaces/postgresql/postgresql-uffi.cl | 190 ++ set-logical.cl | 63 + sql/.cvsignore | 1 + sql/functional.cl | 94 + sql/package.cl | 108 + sql/sql.cl | 467 ++++ test-clsql.cl | 97 + 60 files changed, 7416 insertions(+) create mode 100644 COPYING.CLSQL create mode 100644 COPYING.MaiSQL create mode 100644 ChangeLog create mode 100644 INSTALL create mode 100644 Makefile create mode 100644 NEWS create mode 100644 README create mode 100644 TODO create mode 100644 VERSION create mode 100644 clsql-aodbc.system create mode 100644 clsql-mysql.system create mode 100644 clsql-postgresql-socket.system create mode 100644 clsql-postgresql.system create mode 100644 clsql.system create mode 100755 cmucl-compat/.cvsignore create mode 100644 cmucl-compat/cmucl-compat.cl create mode 100644 cmucl-compat/loop-extension.cl create mode 100755 doc/.cvsignore create mode 100644 doc/Makefile create mode 100644 doc/appendix.sgml create mode 100644 doc/bookinfo.sgml create mode 100644 doc/catalog create mode 100644 doc/clsql.sgml create mode 100644 doc/dsssl/html-docbook.dsl create mode 100644 doc/dsssl/html/docbook.dsl create mode 100644 doc/dsssl/print-docbook.dsl create mode 100644 doc/dsssl/print/docbook.dsl create mode 100644 doc/glossary.sgml create mode 100644 doc/intro.sgml create mode 100644 doc/preface.sgml create mode 100644 doc/ref.sgml create mode 100644 doc/sgml-docbook-4.1.cat create mode 100755 interfaces/aodbc/.cvsignore create mode 100644 interfaces/aodbc/aodbc-package.cl create mode 100644 interfaces/aodbc/aodbc-sql.cl create mode 100755 interfaces/mysql/.cvsignore create mode 100644 interfaces/mysql/Makefile create mode 100644 interfaces/mysql/Makefile.msvc create mode 100644 interfaces/mysql/clsql-mysql.c create mode 100644 interfaces/mysql/mysql-loader.cl create mode 100644 interfaces/mysql/mysql-package.cl create mode 100644 interfaces/mysql/mysql-sql.cl create mode 100644 interfaces/mysql/mysql-uffi.cl create mode 100644 interfaces/mysql/testing/mysql-struct-size.cc create mode 100644 interfaces/mysql/testing/mysql-struct-size.cl create mode 100755 interfaces/postgresql-socket/.cvsignore create mode 100644 interfaces/postgresql-socket/postgresql-socket-package.cl create mode 100644 interfaces/postgresql-socket/postgresql-socket-sql.cl create mode 100644 interfaces/postgresql-socket/postgresql-socket-uffi.cl create mode 100755 interfaces/postgresql/.cvsignore create mode 100644 interfaces/postgresql/postgresql-loader.cl create mode 100644 interfaces/postgresql/postgresql-package.cl create mode 100644 interfaces/postgresql/postgresql-sql.cl create mode 100644 interfaces/postgresql/postgresql-uffi.cl create mode 100644 set-logical.cl create mode 100755 sql/.cvsignore create mode 100644 sql/functional.cl create mode 100644 sql/package.cl create mode 100644 sql/sql.cl create mode 100644 test-clsql.cl diff --git a/COPYING.CLSQL b/COPYING.CLSQL new file mode 100644 index 0000000..e55fd5f --- /dev/null +++ b/COPYING.CLSQL @@ -0,0 +1,16 @@ +CLSQL is written and Copyright (c) 2002 by Kevin M. Rosenberg and is +based on the MaiSQL package written and Copyright (c) 1999-2001 by +Pierre R. Mai. + +CLSQL is licensed under the terms of the Lisp Lesser GNU +Public License (http://opensource.franz.com/preamble.html), known as +the LLGPL. The LLGPL consists of a preamble (see above URL) and the +LGPL. Where these conflict, the preamble takes precedence. +CLSQL is referenced in the preamble as the "LIBRARY." + +CLSQL is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + + diff --git a/COPYING.MaiSQL b/COPYING.MaiSQL new file mode 100644 index 0000000..88c5806 --- /dev/null +++ b/COPYING.MaiSQL @@ -0,0 +1,25 @@ + Copyright (C) 1999-2001 Pierre R. Mai + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. + IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR + OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, + ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR + OTHER DEALINGS IN THE SOFTWARE. + + Except as contained in this notice, the name of the author shall + not be used in advertising or otherwise to promote the sale, use or + other dealings in this Software without prior written authorization + from the author. diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 0000000..7c405bd --- /dev/null +++ b/ChangeLog @@ -0,0 +1,4 @@ +23 Mar 2002 Kevin Rosenberg (kevin@rosenberg.net) + * Initial Release + + diff --git a/INSTALL b/INSTALL new file mode 100644 index 0000000..4c32e51 --- /dev/null +++ b/INSTALL @@ -0,0 +1,5 @@ +Refer to the main documentation file for installation instructions. + +Documentation is availabe as a PDF file in doc/clsql.pdf and +as HTML files in doc/html/. + diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..face895 --- /dev/null +++ b/Makefile @@ -0,0 +1,55 @@ +# FILE IDENTIFICATION +# +# Name: Makefile +# Purpose: Makefile for the CLSQL package +# Programer: Kevin M. Rosenberg +# Date Started: Mar 2002 +# +# CVS Id: $Id: Makefile,v 1.1 2002/03/23 14:04:49 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. + +PACKAGE=clsql + +all: nothing + +nothing: + +clean: + @rm -f $(PACKAGE)-*.tar.gz $(PACKAGE)-*.zip + @find . -type d -name .bin |xargs rm -rf + +realclean: clean + @find . -type f -name \*~ -exec rm {} \; + @find . -type f -name "#*#" -exec rm {} \; + +docs: + @(cd doc; make dist-doc) + +VERSION=$(shell cat VERSION) +DISTDIR=$(PACKAGE)-$(VERSION) +DIST_TARBALL=$(DISTDIR).tar.gz +DIST_ZIP=$(DISTDIR).zip +SOURCE_FILES=interfaces sql cmucl-compat doc Makefile VERSION \ + COPYING.CLSQL COPYING.MaiSQL README INSTALL ChangeLog NEWS TODO \ + set-logical.cl test-clsql.cl \ + clsql.system clsql-aodbc.system clsql-mysql.system \ + clsql-postgresql.system clsql-postgresql-socket.system + +dist: realclean docs + @rm -fr $(DISTDIR) $(DIST_TARBALL) $(DIST_ZIP) + @mkdir $(DISTDIR) + @cp -a $(SOURCE_FILES) $(DISTDIR) + @find $(DISTDIR) -type d -name CVS | xargs rm -r + @find $(DISTDIR) -type f -name .cvsignore -exec rm {} \; + @find $(DISTDIR)/doc -type f -name \*.tex -or -name \*.aux -or \ + -name \*.log -or -name \*.out -or -name \*.dvi -or \ + -name \*~ -or -name \*.ps -exec rm {} \; + @tar czf $(DIST_TARBALL) $(DISTDIR) + @find $(DISTDIR) -type f -exec unix2dos -q {} \; + @zip -rq $(DIST_ZIP) $(DISTDIR) + @rm -r $(DISTDIR) diff --git a/NEWS b/NEWS new file mode 100644 index 0000000..2dbd266 --- /dev/null +++ b/NEWS @@ -0,0 +1 @@ +Initial release of CLSQL diff --git a/README b/README new file mode 100644 index 0000000..1e0895d --- /dev/null +++ b/README @@ -0,0 +1,11 @@ +CLSQL is a Common Lisp to SQL engine interface written by Kevin M. +Rosenberg. It is based Pierre R. Mai's excellent MaiSQL package. It +uses the UFFI (http://uffi.med-info.com) library for compatibility +with Allegro CL, Lispworks, and CMUCL. + +CLSQL's home is http://clsql.med-info.com. + +Documentation is availabe as a PDF file in doc/clsql.pdf and +as HTML files in doc/html/. + + diff --git a/TODO b/TODO new file mode 100644 index 0000000..7d323af --- /dev/null +++ b/TODO @@ -0,0 +1,4 @@ +Fix postgresql-socket on Lispworks and CMUCL so that the +socket stream uses a consistent element-type. + + diff --git a/VERSION b/VERSION new file mode 100644 index 0000000..8ea2ddf --- /dev/null +++ b/VERSION @@ -0,0 +1,2 @@ +0.5.0 + diff --git a/clsql-aodbc.system b/clsql-aodbc.system new file mode 100644 index 0000000..a9a8c4a --- /dev/null +++ b/clsql-aodbc.system @@ -0,0 +1,30 @@ +;;;; -*- 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.1 2002/03/23 14:04:49 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 "CLSQL:interfaces;aodbc;" + :source-extension "cl" + :binary-pathname "CLSQL:interfaces;aodbc;bin;" + :components ((:file "aodbc-package") + (:file "aodbc-sql" :depends-on ("aodbc-package"))) + :depends-on (:clsql) + :finally-do + (clsql-sys:initialize-database-type :database-type :aodbc)) diff --git a/clsql-mysql.system b/clsql-mysql.system new file mode 100644 index 0000000..4122b47 --- /dev/null +++ b/clsql-mysql.system @@ -0,0 +1,41 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql-mysql.system +;;;; Purpose: Defsystem-3/4 definition file for CLSQL MySQL backend +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: clsql-mysql.system,v 1.1 2002/03/23 14:04:49 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) + +(in-package :make) + +;;; System definition + +(defsystem :clsql-mysql + :source-pathname "CLSQL:interfaces;mysql;" + :source-extension "cl" + :binary-pathname "CLSQL:interfaces;mysql;bin;" + :components ((:file "mysql-package") + (:file "mysql-loader" :depends-on ("mysql-package")) + (:file "mysql-uffi" :depends-on ("mysql-loader")) + (:file "mysql-sql" :depends-on ("mysql-uffi"))) + :depends-on (:uffi :clsql) + :finally-do + (progn + (clsql-sys:initialize-database-type :database-type :mysql) + (setq clsql:*default-database-type* :mysql) + (pushnew :mysql cl:*features*))) + + + diff --git a/clsql-postgresql-socket.system b/clsql-postgresql-socket.system new file mode 100644 index 0000000..98467af --- /dev/null +++ b/clsql-postgresql-socket.system @@ -0,0 +1,33 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql-postgresql.system +;;;; Purpose: Defsystem-3/4 file for CLSQL PostgresSQL socket backend +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: clsql-postgresql-socket.system,v 1.1 2002/03/23 14:04:49 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :make) + +;;; System definition + +(defsystem :clsql-postgresql-socket + :source-pathname "CLSQL:interfaces;postgresql-socket;" + :source-extension "cl" + :binary-pathname "CLSQL:interfaces;postgresql-socket;bin;" + :components ((:file "postgresql-socket-package") + (:file "postgresql-socket-uffi" + :depends-on ("postgresql-socket-package")) + (:file "postgresql-socket-sql" + :depends-on ("postgresql-socket-uffi"))) + :depends-on (:clsql)) diff --git a/clsql-postgresql.system b/clsql-postgresql.system new file mode 100644 index 0000000..c956d76 --- /dev/null +++ b/clsql-postgresql.system @@ -0,0 +1,31 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql-postgresql.system +;;;; Purpose: Defsystem-3/4 file for CLSQL PostgresSQL backend +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: clsql-postgresql.system,v 1.1 2002/03/23 14:04:49 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :make) + +(defsystem :clsql-postgresql + :source-pathname "CLSQL:interfaces;postgresql;" + :source-extension "cl" + :binary-pathname "CLSQL:interfaces;postgresql;bin;" + :source-extension "cl" + :components ((:file "postgresql-package") + (:file "postgresql-loader" :depends-on ("postgresql-package")) + (:file "postgresql-uffi" :depends-on ("postgresql-loader")) + (:file "postgresql-sql" :depends-on ("postgresql-uffi"))) + :depends-on (:uffi :clsql)) diff --git a/clsql.system b/clsql.system new file mode 100644 index 0000000..f361df9 --- /dev/null +++ b/clsql.system @@ -0,0 +1,45 @@ +;;;; -*- 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.1 2002/03/23 14:04:49 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) + +(load (make-pathname :name "set-logical" :type "cl" + :defaults *load-truename*)) +(set-logical-host-for-pathname "CLSQL" *load-truename*) + +;;; System definitions + +(mk:defsystem :cmucl-compat + :source-pathname "CLSQL:cmucl-compat;" + :source-extension "cl" + :binary-pathname "CLSQL:cmucl-compat;bin;" + :components ((:file "cmucl-compat") + (:file "loop-extension"))) + +(mk:defsystem :clsql + :source-pathname "CLSQL:sql;" + :source-extension "cl" + :binary-pathname "CLSQL:sql;bin;" + :components ((:file "package") + (:file "sql" :depends-on ("package")) + (:file "functional" :depends-on ("sql"))) + :depends-on (:cmucl-compat) + :finally-do + (pushnew :clsql cl:*features*) + ) diff --git a/cmucl-compat/.cvsignore b/cmucl-compat/.cvsignore new file mode 100755 index 0000000..ca8d09f --- /dev/null +++ b/cmucl-compat/.cvsignore @@ -0,0 +1 @@ +.bin diff --git a/cmucl-compat/cmucl-compat.cl b/cmucl-compat/cmucl-compat.cl new file mode 100644 index 0000000..f2dde00 --- /dev/null +++ b/cmucl-compat/cmucl-compat.cl @@ -0,0 +1,115 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: cmucl-compat.sql +;;;; Purpose: Compatiblity library for CMUCL functions +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: cmucl-compat.cl,v 1.1 2002/03/23 14:04:49 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :cl-user) + +(defpackage :cmucl-compat + (:export + #:shrink-vector + #:make-sequence-of-type + #:result-type-or-lose + #:required-argument + )) +(in-package :cmucl-compat) + +#+cmu +(defmacro required-argument () + `(ext:required-argument)) + +#-cmu +(defun required-argument () + (error "~&A required keyword argument was not supplied")) + +#+cmu +(defmacro shrink-vector (vec len) + `(lisp::shrink-vector ,vec ,len)) + +#-cmu +(defmacro shrink-vector (vec len) + "Shrinks a vector. Optimized if vector has a fill pointer. +Needs to be a macro to overwrite value of VEC." + (let ((new-vec (gensym))) + `(cond + ((adjustable-array-p ,vec) + (adjust-array ,vec ,len)) + ((typep ,vec 'simple-array) + (let ((,new-vec (make-array ,len :element-type + (array-element-type ,vec)))) + (dotimes (i ,len) + (declare (fixnum i)) + (setf (aref ,new-vec i) (aref ,vec i))) + (setq ,vec ,new-vec))) + ((typep ,vec 'vector) + (setf (fill-pointer ,vec) ,len) + ,vec) + (t + (error "Unable to shrink vector ~S which is type-of ~S" ,vec (type-of ,vec))) + ))) + + + +#-cmu +(defun make-sequence-of-type (type length) + "Returns a sequence of the given TYPE and LENGTH." + (declare (fixnum length)) + (case type + (list + (make-list length)) + ((bit-vector simple-bit-vector) + (make-array length :element-type '(mod 2))) + ((string simple-string base-string simple-base-string) + (make-string length)) + (simple-vector + (make-array length)) + ((array simple-array vector) + (if (listp type) + (make-array length :element-type (cadr type)) + (make-array length))) + (t + (make-sequence-of-type (result-type-or-lose type t) length)))) + + +#+cmu +(if (fboundp 'lisp::make-sequence-of-type) + (defun make-sequence-of-type (type len) + (lisp::make-sequence-of-type type len)) + (defun make-sequence-of-type (type len) + (system::make-sequence-of-type type len))) + + +#-cmu +(defun result-type-or-lose (type nil-ok) + (unless (or type nil-ok) + (error "NIL output type invalid for this sequence function")) + (case type + ((list cons) + 'list) + ((string simple-string base-string simple-base-string) + 'string) + (simple-vector + 'simple-vector) + (vector + 'vector) + (t + (error "~S is a bad type specifier for sequence functions." type)) + )) + +#+cmu +(defun result-type-or-lose (type nil-ok) + (lisp::result-type-or-lose type nil-ok)) diff --git a/cmucl-compat/loop-extension.cl b/cmucl-compat/loop-extension.cl new file mode 100644 index 0000000..4eec894 --- /dev/null +++ b/cmucl-compat/loop-extension.cl @@ -0,0 +1,98 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: loop-extension.cl +;;;; Purpose: Extensions to the Loop macro for CMUCL +;;;; Programmer: Pierre R. Mai +;;;; +;;;; Copyright (c) 1999-2001 Pierre R. Mai +;;;; +;;;; $Id: loop-extension.cl,v 1.1 2002/03/23 14:04:49 kevin Exp $ +;;;; +;;;; The functions in this file were orignally distributed in the +;;;; MaiSQL package in the file sql/sql.cl +;;;; ************************************************************************* + +(in-package :cl-user) + +;;;; MIT-LOOP extension + +#+cmu +(defun loop-record-iteration-path (variable data-type prep-phrases) + (let ((in-phrase nil) + (from-phrase nil)) + (loop for (prep . rest) in prep-phrases + do + (case prep + ((:in :of) + (when in-phrase + (ansi-loop::loop-error + "Duplicate OF or IN iteration path: ~S." (cons prep rest))) + (setq in-phrase rest)) + ((:from) + (when from-phrase + (ansi-loop::loop-error + "Duplicate FROM iteration path: ~S." (cons prep rest))) + (setq from-phrase rest)) + (t + (ansi-loop::loop-error + "Unknown preposition: ~S." prep)))) + (unless in-phrase + (ansi-loop::loop-error "Missing OF or IN iteration path.")) + (unless from-phrase + (setq from-phrase '(*default-database*))) + (cond + ((consp variable) + (let ((query-var (ansi-loop::loop-gentemp 'loop-record-)) + (db-var (ansi-loop::loop-gentemp 'loop-record-database-)) + (result-set-var (ansi-loop::loop-gentemp + 'loop-record-result-set-)) + (step-var (ansi-loop::loop-gentemp 'loop-record-step-))) + (push `(when ,result-set-var + (database-dump-result-set ,result-set-var ,db-var)) + ansi-loop::*loop-epilogue*) + `(((,variable nil ,data-type) (,query-var ,(first in-phrase)) + (,db-var ,(first from-phrase)) + (,result-set-var nil) + (,step-var nil)) + ((multiple-value-bind (%rs %cols) + (database-query-result-set ,query-var ,db-var) + (setq ,result-set-var %rs ,step-var (make-list %cols)))) + () + () + (not (database-store-next-row ,result-set-var ,db-var ,step-var)) + (,variable ,step-var) + (not ,result-set-var) + () + (not (database-store-next-row ,result-set-var ,db-var ,step-var)) + (,variable ,step-var)))) + (t + (let ((query-var (ansi-loop::loop-gentemp 'loop-record-)) + (db-var (ansi-loop::loop-gentemp 'loop-record-database-)) + (result-set-var (ansi-loop::loop-gentemp + 'loop-record-result-set-))) + (push `(when ,result-set-var + (database-dump-result-set ,result-set-var ,db-var)) + ansi-loop::*loop-epilogue*) + `(((,variable nil ,data-type) (,query-var ,(first in-phrase)) + (,db-var ,(first from-phrase)) + (,result-set-var nil)) + ((multiple-value-bind (%rs %cols) + (database-query-result-set ,query-var ,db-var) + (setq ,result-set-var %rs ,variable (make-list %cols)))) + () + () + (not (database-store-next-row ,result-set-var ,db-var ,variable)) + () + (not ,result-set-var) + () + (not (database-store-next-row ,result-set-var ,db-var ,variable)) + ())))))) + +#+cmu +(ansi-loop::add-loop-path '(record records tuple tuples) + 'loop-record-iteration-path + ansi-loop::*loop-ansi-universe* + :preposition-groups '((:of :in) (:from)) + :inclusive-permitted nil) diff --git a/doc/.cvsignore b/doc/.cvsignore new file mode 100755 index 0000000..d6dea43 --- /dev/null +++ b/doc/.cvsignore @@ -0,0 +1,8 @@ +clsql.pdf +clsql.ps +clsql.tex +clsql.dvi +clsql.aux +clsql.log +clsql.out +html diff --git a/doc/Makefile b/doc/Makefile new file mode 100644 index 0000000..4c1ecdd --- /dev/null +++ b/doc/Makefile @@ -0,0 +1,108 @@ +# FILE IDENTIFICATION +# +# Name: Makefile +# Purpose: Makefile for the clsql documentation +# Programer: Kevin M. Rosenberg +# Date Started: Mar 2002 +# +# CVS Id: $Id: Makefile,v 1.1 2002/03/23 14:04:49 kevin Exp $ +# +# This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg +# +# UFFI 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. + + + +# Set to DSSSL +# For RedHat 6.x +#DSSSL_HTML=/usr/lib/sgml/stylesheets/nwalsh-modular/html/docbook.dsl +#DSSL_PRINT=/usr/lib/sgml/stylesheets/nwalsh-modular/print/docbook.dsl + +# For RedHat 7.2 +DSSSL_HTML=/usr/share/sgml/docbook/dsssl-stylesheets-1.64/html/docbook.dsl +DSSSL_PRINT=/usr/share/sgml/docbook/dsssl-stylesheets-1.64/print/docbook.dsl + +# Latest version +DSSSL_HTML=/usr/share/sgml/docbook/dsssl-stylesheets-1.76/html/docbook.dsl +DSSSL_PRINT=/usr/share/sgml/docbook/dsssl-stylesheets-1.76/print/docbook.dsl + +# Custom version +DSSSL_HTML=dsssl/html/docbook.dsl +DSSSL_PRINT=dsssl/print/docbook.dsl + +# Nothing to configure beyond this point + +DOCFILE_BASE_DEFAULT=clsql +DOCFILE_EXT_DEFAULT=sgml + +# Standard docfile processing + +ifndef DOCFILE_BASE +DOCFILE_BASE=${DOCFILE_BASE_DEFAULT} +endif + +ifndef DOCFILE_EXT +DOCFILE_EXT=${DOCFILE_EXT_DEFAULT} +endif + +DOCFILE=${DOCFILE_BASE}.${DOCFILE_EXT} +TEXFILE=${DOCFILE_BASE}.tex +PDFFILE=${DOCFILE_BASE}.pdf +PSFILE=${DOCFILE_BASE}.ps +DVIFILE=${DOCFILE_BASE}.dvi +TMPFILES=${DOCFILE_BASE}.aux ${DOCFILE_BASE}.out ${DOCFILE_BASE}.log +DOCFILES=$(shell echo *.sgml) + +all: html pdf ps dvi + +dist-doc: html pdf + +CHECK=nsgmls -s -C catalog || exit 1 + +check: + $(CHECK) + +html: html/manual.htm + +html/manual.htm: ${DOCFILES} + $(CHECK) + ( rm -rf html ; mkdir html; cd html ; jade -t sgml -c ../catalog -d ${DSSSL_HTML} ../${DOCFILE}; mv book1.htm manual.htm; cd ..) + +tex: ${TEXFILE} + +${TEXFILE}: ${DOCFILES} + $(CHECK) + @jade -t tex -c catalog -d ${DSSSL_PRINT} ${DOCFILE} + +pdf: ${PDFFILE} + +${PDFFILE}: ${TEXFILE} + @pdfjadetex '\pdfcompresslevel=9' '\input ${TEXFILE}' + @pdfjadetex '\pdfcompresslevel=9' '\input ${TEXFILE}' + @pdfjadetex '\pdfcompresslevel=9' '\input ${TEXFILE}' + @pdfjadetex '\pdfcompresslevel=9' '\input ${TEXFILE}' + +dvi: ${DVIFILE} + +${DVIFILE}: ${TEXFILE} + jadetex ${TEXFILE} + jadetex ${TEXFILE} + jadetex ${TEXFILE} + jadetex ${TEXFILE} + +ps: ${PSFILE} + +${PSFILE}: ${DVIFILE} + dvips -o ${PSFILE} ${DVIFILE} + +clean: + @rm -rf html + @rm -f ${PSFILE} ${PDFFILE} ${DVIFILE} ${TEXFILE} + @rm -f ${TMPFILES} + +realclean: clean + @rm -f *~ + + diff --git a/doc/appendix.sgml b/doc/appendix.sgml new file mode 100644 index 0000000..dce9cc5 --- /dev/null +++ b/doc/appendix.sgml @@ -0,0 +1,305 @@ + + + + Database Back-ends + + + MySQL + + Libraries + The MySQL back-end needs access to the MySQL C + client library (libmysqlclient.so). + The location of this library is specified via + *mysql-so-load-path*, which defaults + to /usr/lib/libmysqlclient.so. + Additional flags to ld needed for + linking are specified via + *mysql-so-libraries*, + which defaults to ("-lc"). + + + Initialization + Use + (mk:load-system :clsql-mysql) + to load the MySQL back-end. The database type for the MySQL + back-end is :mysql. + + + Connection Specification + + Syntax of connection-spec + (host db user password) + + + Description of connection-spec + + + host + + String representing the hostname or IP address + the MySQL server resides on, or nil + to indicate the localhost. + + + + db + + String representing the name of the database on + the server to connect to. + + + + user + + String representing the user name to use for + authentication, or nil to use the + current Unix user ID. + + + + password + + String representing the unencrypted password to + use for authentication, or nil if + the authentication record has an empty password + field. + + + + + + + + + AODBC + + Libraries + The AODBC back-end requires access to the ODBC interface + of &acl;. + + + Initialization + Use + (mk:load-system :clsql-aodbc) + to load the MySQL back-end. The database type for the AODBC + back-end is :aodbc. + + + Connection Specification + + Syntax of connection-spec + (dsn user password) + + + Description of connection-spec + + + dsn + + String representing the ODBC data source name. + + + + user + + String representing the user name to use for + authentication. + + + + password + + String representing the unencrypted password to + use for authentication. + + + + + + + + + PostgreSQL + + Libraries + The PostgreSQL back-end needs access to the PostgreSQL C + client library (libpq.so). The + location of this library is specified via + *postgresql-so-load-path*, which defaults + to /usr/lib/libpq.so. Additional flags + to ld needed for linking are + specified via *postgresql-so-libraries*, + which defaults to ("-lcrypt" "-lc"). + + + Initialization + Use + (mk:load-system :clsql-postgresql) + to load the PostgreSQL back-end. The database type for the + PostgreSQL back-end is :postgresql. + + + Connection Specification + + Syntax of connection-spec + (host db user password &optional port options tty) + + + Description of connection-spec + For every parameter in the connection-spec, + nil indicates that the PostgreSQL default + environment variables (see PostgreSQL documentation) will + be used, or if those are unset, the compiled-in defaults + of the C client library are used. + + + host + + String representing the hostname or IP address + the PostgreSQL server resides on. Use the empty + string to indicate a connection to localhost via + Unix-Domain sockets instead of TCP/IP. + + + + db + + String representing the name of the database on + the server to connect to. + + + + user + + String representing the user name to use for + authentication. + + + + password + + String representing the unencrypted password to + use for authentication. + + + + port + + String representing the port to use for + communication with the PostgreSQL server. + + + + options + + String representing further runtime options for + the PostgreSQL server. + + + + tty + + String representing the tty or file to use for + debugging messages from the PostgreSQL server. + + + + + + + + + PostgreSQL Socket + + Libraries + The PostgreSQL Socket back-end needs + no access to the PostgreSQL C + client library, since it communicates directly with the + PostgreSQL server using the published frontend/backend + protocol, version 2.0. This eases installation and makes it + possible to dump CMU CL images containing CLSQL and this + backend, contrary to backends which require FFI code. + + + Initialization + Use + (mk:load-system :clsql-postgresql-socket) + to load the PostgreSQL Socket back-end. The database type for the + PostgreSQL Socket back-end is + :postgresql-socket. + + + Connection Specification + + Syntax of connection-spec + (host db user password &optional port options tty) + + + Description of connection-spec + + + host + + If this is a string, it represents the hostname or + IP address the PostgreSQL server resides on. In + this case communication with the server proceeds via + a TCP connection to the given host and port. + + If this is a pathname, then it is assumed to name the + directory that contains the server's Unix-Domain + sockets. The full name to the socket is then + constructed from this and the port number passed, + and communication will proceed via a connection to + this unix-domain socket. + + + + db + + String representing the name of the database on + the server to connect to. + + + + user + + String representing the user name to use for + authentication. + + + + password + + String representing the unencrypted password to + use for authentication. This can be the empty + string if no password is required for + authentication. + + + + port + + Integer representing the port to use for + communication with the PostgreSQL server. This + defaults to 5432. + + + + options + + String representing further runtime options for + the PostgreSQL server. + + + + tty + + String representing the tty or file to use for + debugging messages from the PostgreSQL server. + + + + + + + diff --git a/doc/bookinfo.sgml b/doc/bookinfo.sgml new file mode 100644 index 0000000..964b79c --- /dev/null +++ b/doc/bookinfo.sgml @@ -0,0 +1,55 @@ + + + + &clsql; Users' Guide + + Pierre + R. + Mai + + + Kevin + M. + Rosenberg + + + Release $Name: $ + File $Date: 2002/03/23 14:04:50 $ + $Id: bookinfo.sgml,v 1.1 2002/03/23 14:04:50 kevin Exp $ + + + 1999 + 2001 + 2002 + Pierre R. Mai and Kevin M. Rosenberg + + + + + &clsql; is Copyright © + 1999-2001 by Pierre R. Mai and Copyright © 2002 by + Kevin M. Rosenberg. + + + Allegro CL® is a registered + trademark of Franz Inc. + + + Common SQL, + LispWorks and + Xanalys are trademarks or + registered trademarks of Xanalys Inc. + + + Microsoft + Windows® is a registered trademark of + Microsoft Inc. + + + Other brand or + product names are the registered trademarks or trademarks of + their respective holders. + + + + diff --git a/doc/catalog b/doc/catalog new file mode 100644 index 0000000..5bf6501 --- /dev/null +++ b/doc/catalog @@ -0,0 +1,2 @@ +CATALOG sgml-docbook-4.1.cat +DOCUMENT clsql.sgml diff --git a/doc/clsql.sgml b/doc/clsql.sgml new file mode 100644 index 0000000..2efb961 --- /dev/null +++ b/doc/clsql.sgml @@ -0,0 +1,38 @@ + + +Defsystem"> +CLOCC"> +UFFI"> +FFI"> +CLSQL"> +MaiSQL"> +SQL"> +MySQL"> +PostgreSQL"> +AODBC"> +CMUCL"> +Lispworks"> +AllegroCL"> +ANSI Common Lisp"> +T"> +NIL"> +NULL"> +C"> +defsystem"> + + + + + + +]> + + +&bookinfo; +&preface; +&intro; +&ref; +&appendix; +&glossary; + diff --git a/doc/dsssl/html-docbook.dsl b/doc/dsssl/html-docbook.dsl new file mode 100644 index 0000000..5d1d4dd --- /dev/null +++ b/doc/dsssl/html-docbook.dsl @@ -0,0 +1,30 @@ + +]> + + + + +(element envar ($mono-seq$)) +(element symbol ($mono-seq$)) +(element type ($mono-seq$)) +(element errortype ($mono-seq$)) +(element returnvalue ($italic-mono-seq$)) +(define (book-titlepage-recto-elements) + (list (normalize "title") + (normalize "subtitle") + (normalize "graphic") + (normalize "corpauthor") + (normalize "authorgroup") + (normalize "author") + (normalize "editor") + (normalize "printhistory") + (normalize "copyright") + (normalize "abstract") + (normalize "legalnotice"))) +(define %use-id-as-filename% #t) +(define use-output-dir #t) + --> + --> + + --> diff --git a/doc/dsssl/html/docbook.dsl b/doc/dsssl/html/docbook.dsl new file mode 100644 index 0000000..e0f1668 --- /dev/null +++ b/doc/dsssl/html/docbook.dsl @@ -0,0 +1,30 @@ + +]> + + + + +(element envar ($mono-seq$)) +(element symbol ($mono-seq$)) +(element type ($mono-seq$)) +(element errortype ($mono-seq$)) +(element returnvalue ($italic-mono-seq$)) +(define (book-titlepage-recto-elements) + (list (normalize "title") + (normalize "subtitle") + (normalize "graphic") + (normalize "corpauthor") + (normalize "authorgroup") + (normalize "author") + (normalize "editor") + (normalize "printhistory") + (normalize "copyright") + (normalize "abstract") + (normalize "legalnotice"))) +(define %use-id-as-filename% #t) +(define use-output-dir #t) + + + + diff --git a/doc/dsssl/print-docbook.dsl b/doc/dsssl/print-docbook.dsl new file mode 100644 index 0000000..b04cc07 --- /dev/null +++ b/doc/dsssl/print-docbook.dsl @@ -0,0 +1,30 @@ + +]> + + + + +(element envar ($mono-seq$)) +(element symbol ($mono-seq$)) +(element type ($mono-seq$)) +(element errortype ($mono-seq$)) +(element returnvalue ($italic-mono-seq$)) +(define (book-titlepage-verso-elements) + (list (normalize "title") + (normalize "subtitle") + (normalize "corpauthor") + (normalize "authorgroup") + (normalize "author") + (normalize "editor") + (normalize "edition") + (normalize "pubdate") + (normalize "printhistory") + (normalize "copyright") + (normalize "abstract") + (normalize "legalnotice") + (normalize "revhistory"))) + --> + --> + + --> diff --git a/doc/dsssl/print/docbook.dsl b/doc/dsssl/print/docbook.dsl new file mode 100644 index 0000000..a114d93 --- /dev/null +++ b/doc/dsssl/print/docbook.dsl @@ -0,0 +1,30 @@ + +]> + + + + +(element envar ($mono-seq$)) +(element symbol ($mono-seq$)) +(element type ($mono-seq$)) +(element errortype ($mono-seq$)) +(element returnvalue ($italic-mono-seq$)) +(define (book-titlepage-verso-elements) + (list (normalize "title") + (normalize "subtitle") + (normalize "corpauthor") + (normalize "authorgroup") + (normalize "author") + (normalize "editor") + (normalize "edition") + (normalize "pubdate") + (normalize "printhistory") + (normalize "copyright") + (normalize "abstract") + (normalize "legalnotice") + (normalize "revhistory"))) + + + + diff --git a/doc/glossary.sgml b/doc/glossary.sgml new file mode 100644 index 0000000..9c6153b --- /dev/null +++ b/doc/glossary.sgml @@ -0,0 +1,76 @@ + + + + + This glossary is still very thinly populated, and not all + references in the main text have been properly linked and + coordinated with this glossary. This will hopefully change in + future revisions. + + + + Active database + + + + Connection + + + + Closed Database + + + An object of type closed-database. This is + in contrast to the terms connection, database, active + database or database object + which don't include objects which are closed database. + + + + + database + + + + Foreign Function Interface + (FFI) + + + + An interface from Common Lisp to a external library which + contains compiled functions written in other programming + languages, typically C. + + + + + Database Object + + An object of type database. + + + + Structured Query Language + (SQL) + + + + An ANSI standard language for storing and retrieving data + in a relational database. + + + + + SQL Expression + + Either a string containing a valid SQL statement, or + an object of type sql-expression + This has not been implemented yet, so only strings + are valid SQL expressions for the moment. + + + + + + diff --git a/doc/intro.sgml b/doc/intro.sgml new file mode 100644 index 0000000..bc66323 --- /dev/null +++ b/doc/intro.sgml @@ -0,0 +1,138 @@ + + + + Introduction + + + Purpose + &clsql; is a Common Lisp interface to SQL databases. A number of Common +Lisp implementations and SQL databases are supported.The general +structure of &clsql; is based on the +CommonSQL package by Xanalys. + + + + History + + &clsql; is written by Kevin M. Rosenberg and based substantially +on Pierre R. Mai's excellent &maisql; package. The main changes have +been to port the &ffi; to &uffi;, add to Allegro's ODBC interface as a +supported database, add a compatibility layer for &cmucl; specific +code, and make the code more robust in terms of &mysql; support. + + + + + Prerequisites + + + &defsystem; + &clsql; uses &defsystem to compile and load its +components. &defsystem; is included in the &clocc;. The +defsystem version in the pre-packaged distribution is rather old and +may not function well. The version in CVS tree tree works quite +well. For convenience, a copy of the latest defsystem at the FTP +site +of &clsql;. + + + + + &uffi; + &clsql; uses &uffi; +as a Foreign Function Interface (FFI) to support multiple &cl; +implementations. + +You can download &uffi; from its FTP site. There +are zip files for Microsoft Windows systems and gzipped tar files for +other systems. + + + + Supported Common Lisp Implementation + +The implementations that support &clsql; is governed by the supported +implementations of &uffi;. At the time of the initial release of &clsql;, +the following implementations are supported: + + + &acl; v6.1 on Redhat Linux 7.2 and Microsoft Windows. + &lw; v4.2 on Redhat Linux 7.2 and Microsoft Windows. + &cmucl; 18d on Redhat Linux 7.2. + + + + + Supported &sql; Implementation + + Currently, &clsql; supports the following databases: + + + &mysql; v3.23.49 on Redhat Linux 7.2 and Microsoft Windows. + &postgresql; v7.1 on Redhat Linux 7.2. Support for both direct API connections and TCP socket connections. + Allegro's ODBC interface (&aodbc;) on Redhat Linux 7.2 and Microsoft Windows. + + + + + + + Installation + + + Ensure &defsystem; is loaded + + Simply load the file defsystem.lisp. + +(load "defsystem.lisp") + + + + + + Build <filename>clsql-mysql</filename> helper library + &mysql; uses functions that require 64-bit integer +parameters and return values. The &ffi; in most &clsql; +implementations do not support 64-bit integers. Thus, a C helper +library is required to break these 64-bit integers into two compatible +32-bit integers. + +Makefile's for Microsoft Windows and GNU/Solaris systems +are supplied to build this library. In addition, the DLL and LIB +files for Microsoft Windows are supplied with the distribution. + +To build the library, first move to the directory +interfaces/mysql directory. You may need to +edit Makefile or Makefile.msvc to +correctly specify the location of your &mysql; installation. On UNIX systems, use +the command: +make. On a Microsoft Windows system, +use the command: nmake /f +Makefile.msvc. + + + + Load &uffi; + + Unpack the appropriate &uffi; version for your system which creates a directory +for the &uffi; files. Add that directory to &defsystem; *central-registry*. +You can do that by either pushing the pathname of the directory onto this variable, or +use the new add-registry-location present in the newest versions of +&defsystem;. The below example code assumes the &uffi; files reside in the +/usr/local/src/lisp/uffi directory. + + (mk:add-registry-location #P"/usr/local/src/lisp/uffi") + (mk:load-system :uffi) + + + + + + + diff --git a/doc/preface.sgml b/doc/preface.sgml new file mode 100644 index 0000000..aea33b4 --- /dev/null +++ b/doc/preface.sgml @@ -0,0 +1,15 @@ + + + + Preface + This guide provides reference + to the features of &clsql;. The first + chapter provides an introduction to &clsql; and installation + instructions. + Following that chapter is the reference section for all user + accessible symbols of &clsql; with examples of usage, + followed by the reference section for all accessible symbols of + the database back-end interface. At the end there you will find + a glossary of commonly used terms with their + definitions. + diff --git a/doc/ref.sgml b/doc/ref.sgml new file mode 100644 index 0000000..71d6da3 --- /dev/null +++ b/doc/ref.sgml @@ -0,0 +1,2392 @@ + + + + <symbol>CLSQL</symbol> + + This part gives a reference to all the symbols exported + from the package CLSQL-SYS, which are also + re-exported from the package CLSQL. These + symbols constitute the normal user-interface of + &clsql;. + + + + + CLSQL-CONDITION + the super-type of all + &clsql;-specific + conditions + Condition Type + + + Class Precedence List + + + maisql-condition + condition + t + + + + + Description + This is the super-type of all + &clsql;-specific conditions + defined by &clsql;, or any of it's + database-specific interfaces. There are no defined + initialization arguments nor any accessors. + + + + + CLSQL-ERROR + the super-type of all + &clsql;-specific + errors + Condition Type + + + Class Precedence List + + + maisql-error + error + serious-condition + maisql-condition + condition + t + + + + + Description + This is the super-type of all + &clsql;-specific conditions that + represent errors, as defined by + &clsql;, or any of it's + database-specific interfaces. There are no defined + initialization arguments nor any accessors. + + + + + CLSQL-SIMPLE-ERROR + Unspecific simple + &clsql; errors + Condition Type + + + Class Precedence List + + + maisql-simple-error + simple-condition + maisql-error + error + serious-condition + maisql-condition + condition + t + + + + + Description + This condition is used in all instances of errors, where + there exists no &clsql;-specific + condition that is more specific. The valid initialization + arguments and accessors are the same as for + simple-condition. + + + + + CLSQL-WARNING + the super-type of all + &clsql;-specific + warnings + Condition Type + + + Class Precedence List + + + maisql-warning + warning + maisql-condition + condition + t + + + + + Description + This is the super-type of all + &clsql;-specific conditions that + represent warnings, as defined by + &clsql;, or any of it's + database-specific interfaces. There are no defined + initialization arguments nor any accessors. + + + + + CLSQL-SIMPLE-WARNING + Unspecific simple + &clsql; warnings + Condition Type + + + Class Precedence List + + + maisql-simple-warning + simple-condition + maisql-warning + warning + maisql-condition + condition + t + + + + + Description + This condition is used in all instances of warnings, + where there exists no + &clsql;-specific condition that is + more specific. The valid initialization arguments and + accessors are the same as for + simple-condition. + + + + + + CLSQL-INVALID-SPEC-ERROR + condition representing errors because of invalid + connection specifications + Condition Type + + + Class Precedence List + + + maisql-invalid-spec-error + maisql-error + error + serious-condition + maisql-condition + condition + t + + + + + Description + This condition represents errors that occur because the + user supplies an invalid connection specification to either + database-name-from-spec or + connect. The following initialization + arguments and accessors exist: + + Initarg + Accessor + Description + + :connection-spec + maisql-invalid-spec-error-connection-spec + The invalid connection specification used. + + + :database-type + maisql-invalid-spec-error-database-type + The Database type used in the attempt. + + + :template + maisql-invalid-spec-error-template + An argument describing the template that a valid + connection specification must match for this database type. + + + + + + + CLSQL-CONNECT-ERROR + condition representing errors during + connection + Condition Type + + + Class Precedence List + + + maisql-connect-error + maisql-error + error + serious-condition + maisql-condition + condition + t + + + + + Description + This condition represents errors that occur while trying + to connect to a database. The following initialization + arguments and accessors exist: + + Initarg + Accessor + Description + + :database-type + maisql-connect-error-database-type + Database type for the connection attempt + + + :connection-spec + maisql-connect-error-connection-spec + The connection specification used in the + connection attempt. + + + :errno + maisql-connect-error-errno + The numeric or symbolic error specification + returned by the database back-end. The values and + semantics of this are interface specific. + + + :error + maisql-connect-error-error + A string describing the problem that occurred, + possibly one returned by the database back-end. + + + + + + + CLSQL-SQL-ERROR + condition representing errors during query or + command execution + Condition Type + + + Class Precedence List + + + maisql-sql-error + maisql-error + error + serious-condition + maisql-condition + condition + t + + + + + Description + This condition represents errors that occur while + executing SQL statements, either as part of query operations + or command execution, either explicitly or implicitly, as + caused e.g. by with-transaction. + The following initialization arguments and accessors exist: + + Initarg + Accessor + Description + + :database + maisql-sql-error-database + The database object that was involved in the + incident. + + + :expression + maisql-sql-error-expression + The SQL expression whose execution caused the error. + + + :errno + maisql-sql-error-errno + The numeric or symbolic error specification + returned by the database back-end. The values and + semantics of this are interface specific. + + + :error + maisql-sql-error-error + A string describing the problem that occurred, + possibly one returned by the database back-end. + + + + + + + CLSQL-EXISTS-CONDITION + condition indicating situations arising because of + existing connections + Condition Type + + + Class Precedence List + + + maisql-exists-condition + maisql-condition + condition + t + + + + + Description + This condition is the super-type of all conditions which + represents problems that occur during calls to + connect, if a connection to the + database exists already. Depending on the value of + if-exists to the call of + connect, either a warning, an error or + no condition at all is signalled. If a warning or error is + signalled, either + maisql-exists-warning or + maisql-exists-error is signalled, + which are subtypes of + maisql-exists-condition and + maisql-warning or + maisql-error. + maisql-exists-condition is never + signalled itself. + + The following initialization arguments and accessors exist: + + Initarg + Accessor + Description + + :old-db + maisql-exists-condition-old-db + The database object that represents the existing + connection. This slot is always filled. + + + :new-db + maisql-exists-condition-new-db + The database object that will be used and returned by + this call to connect, if execution continues normally. + This can be either nil, indicating that + a new database object is to be created on continuation, + or a database object representing the newly created + continuation, or the same database object as + old-db, indicating that the existing + database object will be reused. This slot is always + filled and defaults to nil. + + + + + + + CLSQL-EXISTS-WARNING + condition representing warnings arising because of + existing connections + Condition Type + + + Class Precedence List + + + maisql-exists-warning + maisql-exists-condition + maisql-warning + warning + maisql-condition + condition + t + + + + + Description + This condition is a subtype of + maisql-exists-condition, and is + signalled during calls to connect when + there is an existing connection, and + if-exists is either + :warn-new or :warn-old. + In the former case, new-db will be the + newly created database object, in the latter case it will be + the existing old database object. + + The initialization arguments and accessors are the same as + for maisql-exists-condition. + + + + + CLSQL-EXISTS-ERROR + condition representing errors arising because of + existing connections + Condition Type + + + Class Precedence List + + + maisql-exists-error + maisql-exists-condition + maisql-error + error + serious-condition + maisql-condition + condition + t + + + + + Description + This condition is a subtype of + maisql-exists-condition, and is + signalled during calls to connect when + there is an existing connection, and + if-exists is :error. + In this case, new-db will be + nil, indicating that the database object to + be returned by connect depends on user + action in continuing from this correctable error. + + The initialization arguments and accessors are the same as + for maisql-exists-condition. + + + + + CLSQL-CLOSED-ERROR + condition representing errors because the database + has already been closed + Condition Type + + + Class Precedence List + + + maisql-closed-error + maisql-error + error + serious-condition + maisql-condition + condition + t + + + + + Description + This condition represents errors that occur because the + user invokes an operation on the given database object, + although the database is invalid because + disconnect has already been called on + this database object. + Functions which signal this error when called with a + closed database will usually provide a + continue restart, that will just return nil + from the function. + + The following initialization arguments and accessors exist: + + Initarg + Accessor + Description + + :database + maisql-closed-error-database + The database object that was involved in the + incident. + + + + + + + + + *DEFAULT-DATABASE-TYPE* + The default database type to use + Variable + + + Value Type + Any keyword representing a valid database back-end of + &clsql;, or + nil. + + + Initial Value + nil + + + Description + The value of this variable is used in calls to + initialize-database-type and + connect as the default + value of the database-type + parameter. + + If the value of this variable is nil, + then all calls to + initialize-database-type or + connect will have to specify the + database-type to use, or a + general-purpose error will be signalled. + + + + Examples + +(setf *default-database-type* :mysql) +=> :mysql +(initialize-database-type) +=> t + + + + Affected By + None. + + + See Also + None. + + + Notes + None. + + + + + *INITIALIZED-DATABASE-TYPES* + List of all initialized database types + Variable + + + Value Type + A list of all initialized database types, each of which + represented by it's corresponding keyword. + + + Initial Value + nil + + + Description + This variable is updated whenever + initialize-database-type is called for a + database type which hasn't already been initialized before, + as determined by this variable. In that case the keyword + representing the database type is pushed onto the list + stored in + *INITIALIZED-DATABASE-TYPES*. + + Attempts to modify the value of this variable will + result in undefined behaviour. + + + + Examples + +(setf *default-database-type* :mysql) +=> :mysql +(initialize-database-type) +=> t +*initialized-database-types* +=> (:MYSQL) + + + + Affected By + + + initialize-database-type + + + + + See Also + None. + + + Notes + Direct access to this variable is primarily provided + because of compatibility with Harlequin's Common + SQL. + + + + + INITIALIZE-DATABASE-TYPE + Initializes a database type + Function + + + Syntax + initialize-database-type &key database-type => result + + + Arguments and Values + + + database-type + + The database type to initialize, i.e. a keyword + symbol denoting a known database back-end. Defaults to + the value of + *default-database-type*. + + + + result + + Either nil if the initialization + attempt fails, or t otherwise. + + + + + + Description + If the back-end specified by + database-type has not already been + initialized, as seen from + *initialized-database-types*, an attempt is + made to initialize the database. If this attempt succeeds, + or the back-end has already been initialized, the function + returns t, and places the keyword denoting the database type + onto the list stored in + *initialized-database-types*, if not + already present. + If initialization fails, the function returns + nil, and/or signals an error of type + maisql-error. The kind of action + taken depends on the back-end and the cause of the + problem. + + + Examples + +*initialized-database-types* +=> NIL +(setf *default-database-type* :mysql) +=> :MYSQL +(initialize-database-type) +>> Compiling LAMBDA (#:G897 #:G898 #:G901 #:G902): +>> Compiling Top-Level Form: +>> +=> T +*initialized-database-types* +=> (:MYSQL) +(initialize-database-type) +=> T +*initialized-database-types* +=> (:MYSQL) + + + + Side Effects + The database back-end corresponding to the database type + specified is initialized, unless it has already been + initialized. This can involve any number of other side + effects, as determined by the back-end implementation (like + e.g. loading of foreign code, calling of foreign code, + networking operations, etc.). If initialization is + attempted and succeeds, the + database-type is pushed onto the list + stored in + *initialized-database-types*. + + + Affected by + + + *default-database-type* + *initialized-database-types* + + + + + Exceptional Situations + If an error is encountered during the initialization + attempt, the back-end may signal errors of kind + maisql-error. + + + See Also + None. + + + Notes + None. + + + + + + *CONNECT-IF-EXISTS* + Default value for the + if-exists parameter of + connect. + Variable + + + Value Type + A valid argument to the if-exists + parameter of connect, i.e. one of + + :new + :warn-new + :error + :warn-old + :old + . + + + + Initial Value + :error + + + Description + The value of this variable is used in calls to + connect as the default + value of the if-exists + parameter. See connect for + the semantics of the valid values for this variable. + + + Examples + None. + + + Affected By + None. + + + See Also + + + connect + + + + + Notes + None. + + + + + CONNECTED-DATABASES + Return the list of active database + objects. + Function + + + Syntax + connected-databases => databases + + + Arguments and Values + + + databases + + The list of active database objects. + + + + + + Description + This function returns the list of active database + objects, i.e. all those database objects created by calls to + connect, which have not been closed by + calling disconnect on them. + + The consequences of modifying the list returned by + connected-databases are + undefined. + + + + Examples + +(connected-databases) +=> NIL +(connect '(nil "template1" "dent" nil) :database-type :postgresql) +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {4830BC65}> +(connect '("dent" "newesim" "dent" "dent") :database-type :mysql) +=> #<CLSQL-MYSQL:MYSQL-DATABASE {4830C5AD}> +(connected-databases) +=> (#<CLSQL-MYSQL:MYSQL-DATABASE {4830C5AD}> + #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {4830BC65}>) +(disconnect) +=> T +(connected-databases) +=> (#<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {4830BC65}>) +(disconnect) +=> T +(connected-databases) +=> NIL + + + + Side Effects + None. + + + Affected By + + + connect + disconnect + + + + + Exceptional Situations + None. + + + See Also + None. + + + Notes + None. + + + + + *DEFAULT-DATABASE* + The default database object to use + Variable + + + Value Type + Any object of type database, or nil to + indicate no default database. + + + Initial Value + nil + + + Description + Any function or macro in + &clsql; that operates on a + database uses the value of this variable as the default + value for it's database + parameter. + The value of this parameter is changed by calls to + connect, which sets + *default-database* to the database object + it returns. It is also changed by calls to + disconnect, when the database object + being disconnected is the same as the value of + *default-database*. In this case + disconnect sets + *default-database* to the first database + that remains in the list of active databases as returned by + connected-databases, or + nil if no further active databases + exist. + The user may change *default-database* + at any time to a valid value of his choice. + + If the value of *default-database* is + nil, then all calls to + &clsql; functions on databases + must provide a suitable database + parameter, or an error will be signalled. + + + + Examples + +(connected-databases) +=> NIL +(connect '("dent" "newesim" "dent" "dent") :database-type :mysql) +=> #<CLSQL-MYSQL:MYSQL-DATABASE {48385F55}> +(connect '(nil "template1" "dent" nil) :database-type :postgresql) +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {483868FD}> +(connect '("dent" "newesim" "dent" "dent") :database-type :mysql :if-exists :new) +=> #<CLSQL-MYSQL:MYSQL-DATABASE {48387265}> +*default-database* +=> #<CLSQL-MYSQL:MYSQL-DATABASE {48387265}> +(disconnect) +=> T +*default-database* +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {483868FD}> +(disconnect) +=> T +*default-database* +=> #<CLSQL-MYSQL:MYSQL-DATABASE {48385F55}> +(disconnect) +=> T +*default-database* +=> NIL +(connected-databases) +=> NIL + + + + Affected By + + + connect + disconnect + + + + + See Also + + + connected-databases + + + + + Notes + + This variable is intended to facilitate working with + &clsql; in an interactive + fashion at the top-level loop, and because of this, + connect and + disconnect provide some fairly + complex behaviour to keep + *default-database* set to useful values. + Programmatic use of &clsql; + should never depend on the value of + *default-database* and should provide + correct database objects via the + database parameter to functions + called. + + + + + + + DATABASE + The super-type of all + &clsql; databases + Class + + + Class Precedence List + + + database + standard-object + t + + + + + Description + This class is the superclass of all + &clsql; databases. The different + database back-ends derive subclasses of this class to + implement their databases. No instances of this class are + ever created by &clsql;. + + + + + CLOSED-DATABASE + The class representing all closed + &clsql; databases + Class + + + Class Precedence List + + + closed-database + standard-object + t + + + + + Description + &clsql; database + instances are changed to this class via + change-class after they are closed via + disconnect. All functions and generic + functions that take database objects as arguments will + signal errors of type + maisql-closed-error when they are + called on instances of closed-database, with + the exception of database-name, which + will continue to work as for instances of + database. + + + + + + DATABASE-NAME + Get the name of a database object + Generic Function + + + Syntax + database-name database => name + + + Arguments and Values + + + database + + A database object, either of type + database or of type + closed-database. + + + + name + + A string describing the identity of the database + to which this database object is connected to. + + + + + + Description + This function returns the database name of the given + database. The database name is a string which somehow + describes the identity of the database to which this + database object is or has been connected. The database name + of a database object is determined at + connect time, when a call to + database-name-from-spec derives the + database name from the connection specification passed to + connect in the + connection-spec parameter. + The database name is used via + find-database in + connect to determine whether database + connections to the specified database exist already. + Usually the database name string will include + indications of the host, database name, user, or port that + where used during the connection attempt. The only + important thing is that this string shall try to identify + the database at the other end of the connection. Connection + specifications parts like passwords and credentials shall + not be used as part of the database name. + + + Examples + +(database-name-from-spec '("dent" "newesim" "dent" "dent") :mysql) +=> "dent/newesim/dent" +(connect '("dent" "newesim" "dent" "dent") :database-type :mysql) +=> #<CLSQL-MYSQL:MYSQL-DATABASE {48391DCD}> +(database-name *default-database*) +=> "dent/newesim/dent" + +(database-name-from-spec '(nil "template1" "dent" nil) :postgresql) +=> "/template1/dent" +(connect '(nil "template1" "dent" nil) :database-type :postgresql) +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {48392D2D}> +(database-name *default-database*) +=> "/template1/dent" + +(database-name-from-spec '("www.pmsf.de" "template1" "dent" nil) :postgresql) +=> "www.pmsf.de/template1/dent" + + + + Side Effects + None. + + + Affected By + + + database-name-from-spec + + + + + Exceptional Situations + Will signal an error if the object passed as the + database parameter is neither of type + database nor of type + closed-database. + + + See Also + + + connect + find-database + + + + + Notes + None. + + + + + FIND-DATABASE + Locate a database object through it's + name. + Function + + + Syntax + find-database database &optional errorp => result + + + Arguments and Values + + + database + + A database object or a string, denoting a database + name. + + + + errorp + + A generalized boolean. Defaults to + t. + + + + result + + Either a database object, or, if + errorp is nil, + possibly nil. + + + + + + Description + find-database locates an active + database object given the specification in + database. If + database is an object of type + database, find-database + returns this. Otherwise it will search the active databases + as indicated by the list returned by + connected-databases for a database + whose name (as returned by + database-name is equal as per + string= to the string passed as + database. If it succeeds, it returns + the first database found. + If it fails to find a matching database, it will signal + an error of type maisql-error if + errorp is true. If + errorp is nil, it + will return nil instead. + + + Examples + +(database-name-from-spec '("dent" "newesim" "dent" "dent") :mysql) +=> "dent/newesim/dent" +(connect '("dent" "newesim" "dent" "dent") :database-type :mysql) +=> #<CLSQL-MYSQL:MYSQL-DATABASE {48391DCD}> +(database-name *default-database*) +=> "dent/newesim/dent" + +(database-name-from-spec '(nil "template1" "dent" nil) :postgresql) +=> "/template1/dent" +(connect '(nil "template1" "dent" nil) :database-type :postgresql) +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {48392D2D}> +(database-name *default-database*) +=> "/template1/dent" + +(database-name-from-spec '("www.pmsf.de" "template1" "dent" nil) :postgresql) +=> "www.pmsf.de/template1/dent" + +(find-database "dent/newesim/dent") +=> #<CLSQL-MYSQL:MYSQL-DATABASE {484E91C5}> +(find-database "/template1/dent") +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {48392D2D}> +(find-database "www.pmsf.de/template1/dent" nil) +=> NIL +(find-database **) +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {48392D2D}> + + + + Side Effects + None. + + + Affected By + + + connected-databases + + + + + Exceptional Situations + Will signal an error of type + maisql-error if no matching database + can be found, and errorp is true. + Will signal an error if the value of + database is neither an object of type + database nor a string. + + + See Also + + + database-name + database-name-from-spec + + + + + Notes + None. + + + + + CONNECT + create a connection to a database + Function + + + Syntax + connect connection-spec &key if-exists database-type => database + + + Arguments and Values + + + connection-spec + + A connection specification + + + + if-exists + + This indicates the action to take if a connection + to the same database exists already. See below for the + legal values and actions. It defaults to the value of + *connect-if-exists*. + + + + database-type + + A database type specifier, i.e. a keyword. + This defaults to the value of + *default-database-type* + + + + database + + The database object representing the connection. + + + + + + Description + This function takes a connection specification and + a database type and creates a connection to the database + specified by those. The type and structure of the + connection specification depend on the database type. + The parameter if-exists specifies + what to do if a connection to the database specified exists + already, which is checked by calling + find-database on the database name + returned by database-name-from-spec + when called with the connection-spec + and database-type parameters. The + possible values of if-exists are: + + + :new + + Go ahead and create a new connection. + + + + :warn-new + + This is just like :new, but + also signals a warning of type + maisql-exists-warning, + indicating the old and newly created + databases. + + + + :error + + This will cause connect to + signal a correctable error of type + maisql-exists-error. The + user may choose to proceed, either by indicating + that a new connection shall be created, via the + restart create-new, or by + indicating that the existing connection shall be + used, via the restart + use-old. + + + + :old + + This will cause connect to + use an old connection if one exists. + + + + :warn-old + + This is just like :old, but + also signals a warning of type + maisql-exists-warning, + indicating the old database used, via the slots + old-db and + new-db + + + + + The database name of the returned database object will + be the same under string= as that which + would be returned by a call to + database-name-from-spec with the given + connection-spec and + database-type parameters. + + + Examples + +(database-name-from-spec '("dent" "newesim" "dent" "dent") :mysql) +=> "dent/newesim/dent" +(connect '("dent" "newesim" "dent" "dent") :database-type :mysql) +=> #<CLSQL-MYSQL:MYSQL-DATABASE {48036F6D}> +(database-name *) +=> "dent/newesim/dent" + +(connect '("dent" "newesim" "dent" "dent") :database-type :mysql) +>> In call to CONNECT: +>> There is an existing connection #<CLSQL-MYSQL:MYSQL-DATABASE {48036F6D}> to database dent/newesim/dent. +>> +>> Restarts: +>> 0: [CREATE-NEW] Create a new connection. +>> 1: [USE-OLD ] Use the existing connection. +>> 2: [ABORT ] Return to Top-Level. +>> +>> Debug (type H for help) +>> +>> (CONNECT ("dent" "newesim" "dent" "dent") :IF-EXISTS NIL :DATABASE-TYPE ...) +>> Source: +>> ; File: /prj/CLSQL/sql/sql.cl +>> (RESTART-CASE (ERROR 'CLSQL-EXISTS-ERROR :OLD-DB OLD-DB) +>> (CREATE-NEW NIL :REPORT "Create a new connection." +>> (SETQ RESULT #)) +>> (USE-OLD NIL :REPORT "Use the existing connection." +>> (SETQ RESULT OLD-DB))) +>> 0] 0 +=> #<CLSQL-MYSQL:MYSQL-DATABASE {480451F5}> + + + + Side Effects + A database connection is established, and the resultant + database object is registered, so as to appear in the list + returned by connected-databases. + + + Affected by + + + *default-database-type* + *connect-if-exists* + + + + + Exceptional Situations + If the connection specification is not syntactically or + semantically correct for the given database type, an error + of type maisql-invalid-spec-error is + signalled. If during the connection attempt an error is + detected (e.g. because of permission problems, network + trouble or any other cause), an error of type + maisql-connect-error is + signalled. + If a connection to the database specified by + connection-spec exists already, + conditions are signalled according to the + if-exists parameter, as described + above. + + + See Also + + + connected-databases + disconnect + + + + + Notes + None. + + + + + DISCONNECT + close a database connection + Function + + + Syntax + disconnect &key database => t + + + Arguments and Values + + + database + + The database to disconnect, which defaults to the + database indicated by + *default-database*. + + + + + + Description + This function takes a database object as + returned by connect, and closes the + connection. The class of the object passed is changed to + closed-database after the disconnection + succeeds, thereby preventing further use of the object as + an argument to &clsql; functions, + with the exception of database-name. + If the user does pass a closed database object to any other + &clsql; function, an error of type + maisql-closed-error is + signalled. + + + Examples + +(disconnect :database (find-database "dent/newesim/dent")) +=> T + + + + Side Effects + The database connection is closed, and the database + object is removed from the list of connected databases as + returned by connected-databases. + The class of the database object is changed to + closed-database. + If the database object passed is the same under + eq as the value of + *default-database*, then + *default-database* is set to the first + remaining database from + connected-databases or to nil if no + further active database exists. + + + Affected by + + + *default-database* + + + + + Exceptional Situations + If during the disconnection attempt an error is + detected (e.g. because of network trouble or any other + cause), an error of type maisql-error + might be signalled. + + + See Also + + + connect + closed-database + + + + + Notes + None. + + + + + DATABASE-NAME-FROM-SPEC + Return the database name string corresponding to + the given connection specification. + Generic Function + + + Syntax + + database-name-from-spec connection-spec database-type => name + + + Arguments and Values + + + connection-spec + + A connection specification, whose structure and + interpretation are dependent on the + database-type. + + + + database-type + + A database type specifier, i.e. a keyword. + + + + name + + A string denoting a database name. + + + + + + Description + This generic function takes a connection specification + and a database type and returns the database name of the + database object that would be created had + connect been called with the given + connection specification and database types. + This function is useful in determining a database name + from the connection specification, since the way the + connection specification is converted into a database name + is dependent on the database type. + + + Examples + +(database-name-from-spec '("dent" "newesim" "dent" "dent") :mysql) +=> "dent/newesim/dent" +(connect '("dent" "newesim" "dent" "dent") :database-type :mysql) +=> #<CLSQL-MYSQL:MYSQL-DATABASE {48391DCD}> +(database-name *default-database*) +=> "dent/newesim/dent" + +(database-name-from-spec '(nil "template1" "dent" nil) :postgresql) +=> "/template1/dent" +(connect '(nil "template1" "dent" nil) :database-type :postgresql) +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {48392D2D}> +(database-name *default-database*) +=> "/template1/dent" + +(database-name-from-spec '("www.pmsf.de" "template1" "dent" nil) :postgresql) +=> "www.pmsf.de/template1/dent" + +(find-database "dent/newesim/dent") +=> #<CLSQL-MYSQL:MYSQL-DATABASE {484E91C5}> +(find-database "/template1/dent") +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {48392D2D}> +(find-database "www.pmsf.de/template1/dent" nil) +=> NIL +(find-database **) +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {48392D2D}> + + + + Side Effects + None. + + + Affected by + None. + + + Exceptional Situations + If the value of connection-spec + is not a valid connection specification for the given + database type, an error of type + maisql-invalid-spec-error might be + signalled. + + + See Also + + + connect + + + + + Notes + None. + + + + + + EXECUTE-COMMAND + Execute an SQL command which returns no + values. + Function + + + Syntax + execute-command sql-expression &key database => t + + + Arguments and Values + + + sql-expression + + An sql + expression that represents an SQL + statement which will return no values. + + + + database + + A + database + object. This will default to the value + of *default-database*. + + + + + + Description + This will execute the command given by + sql-expression in the + database specified. If the execution + succeeds it will return t, otherwise an + error of type maisql-sql-error will + be signalled. + + + Examples + +(execute-command "create table eventlog (time char(30),event char(70))") +=> T + +(execute-command "create table eventlog (time char(30),event char(70))") +>> +>> While accessing database #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {480B2B6D}> +>> with expression "create table eventlog (time char(30),event char(70))": +>> Error NIL: ERROR: amcreate: eventlog relation already exists +>> has occurred. +>> +>> Restarts: +>> 0: [ABORT] Return to Top-Level. +>> +>> Debug (type H for help) +>> +>> (CLSQL-POSTGRESQL::|(PCL::FAST-METHOD DATABASE-EXECUTE-COMMAND (T POSTGRESQL-DATABASE))| +>> #<unused-arg> +>> #<unused-arg> +>> #<unavailable-arg> +>> #<unavailable-arg>) +>> Source: (ERROR 'CLSQL-SQL-ERROR :DATABASE DATABASE :EXPRESSION ...) +>> 0] 0 + +(execute-command "drop table eventlog") +=> T + + + + Side Effects + Whatever effects the execution of the SQL statement has + on the underlying database, if any. + + + Affected by + None. + + + Exceptional Situations + If the execution of the SQL statement leads to any + errors, an error of type + maisql-sql-error is signalled. + + + See Also + + + query + + + + + Notes + None. + + + + + QUERY + Execute an SQL query and return the tuples as a + list + Function + + + Syntax + query query-expression &key database => result + + + Arguments and Values + + + query-expression + + An sql + expression that represents an SQL + query which is expected to return a (possibly empty) + result set. + + + + database + + A + database + object. This will default to the value + of *default-database*. + + + + result + + A list representing the result set obtained. For + each tuple in the result set, there is an element in + this list, which is itself a list of all the attribute + values in the tuple. + + + + + + Description + This will execute the query given by + query-expression in the + database specified. If the execution + succeeds it will return the result set returned by the + database, otherwise an error of type + maisql-sql-error will + be signalled. + + + Examples + +(execute-command "create table simple (name char(50), salary numeric(10,2))") +=> T +(execute-command "insert into simple values ('Mai, Pierre',10000)") +=> T +(execute-command "insert into simple values ('Hacker, Random J.',8000.50)") +=> T +(query "select * from simple") +=> (("Mai, Pierre" "10000.00") ("Hacker, Random J." "8000.50")) +(query "select salary from simple") +=> (("10000.00") ("8000.50")) +(query "select salary from simple where salary > 10000") +=> NIL +(query "select salary,name from simple where salary > 10000") +=> NIL +(query "select salary,name from simple where salary > 9000") +=> (("10000.00" "Mai, Pierre")) +(query "select salary,name from simple where salary > 8000") +=> (("10000.00" "Mai, Pierre") ("8000.50" "Hacker, Random J.")) + +;; MySQL-specific: +(query "show tables") +=> (("demo") ("log") ("newlog") ("simple") ("spacetrial")) + + + + Side Effects + Whatever effects the execution of the SQL query has + on the underlying database, if any. + + + Affected by + None. + + + Exceptional Situations + If the execution of the SQL query leads to any + errors, an error of type + maisql-sql-error is signalled. + + + See Also + + + execute-command + + + + + Notes + None. + + + + + + MAP-QUERY + Map a function over all the tuples from a + query + Function + + + Syntax + map-query output-type-spec function query-expression &key database => result + + + Arguments and Values + + + output-type-spec + + A sequence type specifier or nil. + + + + function + + A function designator. + function must take as many + arguments as are attributes in the result set returned + by executing the SQL + query-expression. + + + + query-expression + + An sql + expression that represents an SQL + query which is expected to return a (possibly empty) + result set, where each tuple has as many attributes as + function takes arguments. + + + + database + + A + database + object. This will default to the value + of *default-database*. + + + + result + + If output-type-spec is a + type specifier other than nil, then a + sequence of the type it denotes. Otherwise + nil is returned. + + + + + + Description + Applies function to the + attributes of successive tuples in the result set returned + by executing the SQL + query-expression. If the + output-type-spec is + nil, then the result of each application + of function is discarded, and + map-query returns + nil. Otherwise the result of each + successive application of function is + collected in a sequence of type + output-type-spec, where the jths + element is the result of applying + function to the attributes of the + jths tuple in the result set. The collected sequence is the + result of the call to map-query. + + If the output-type-spec is a + subtype of list, the result will be a + list. + If the result-type is a subtype + of vector, then if the implementation can + determine the element type specified for the + result-type, the element type of the + resulting array is the result of + upgrading that element type; or, if the + implementation can determine that the element type is + unspecified (or *), the element type of the + resulting array is t; otherwise, an error is + signaled. + + + Examples + +(map-query 'list #'(lambda (salary name) + (declare (ignorable name)) + (read-from-string salary)) + "select salary,name from simple where salary > 8000") +=> (10000.0 8000.5) + +(map-query '(vector double-float) + #'(lambda (salary name) + (declare (ignorable name)) + (coerce (read-from-string salary) 'double-float)) + "select salary,name from simple where salary > 8000") +=> #(10000.0d0 8000.5d0) +(type-of *) +=> (SIMPLE-ARRAY DOUBLE-FLOAT (2)) + +(let (list) + (values (map-query nil #'(lambda (salary name) + (push (cons name (read-from-string salary)) list)) + "select salary,name from simple where salary > 8000") + list)) +=> NIL +=> (("Hacker, Random J." . 8000.5) ("Mai, Pierre" . 10000.0)) + + + + Side Effects + Whatever effects the execution of the SQL query has + on the underlying database, if any. + + + Affected by + None. + + + Exceptional Situations + If the execution of the SQL query leads to any + errors, an error of type + maisql-sql-error is signalled. + An error of type type-error must + be signaled if the output-type-spec is + not a recognizable subtype of list, not a + recognizable subtype of vector, and not + nil. + An error of type type-error + should be signaled if + output-type-spec specifies the number + of elements and the size of the result set is different from + that number. + + + See Also + + + query + do-query + + + + + Notes + None. + + + + + DO-QUERY + Iterate over all the tuples of a + query + Macro + + + Syntax + do-query ((&rest args) query-expression &key database) &body body => nil + + + Arguments and Values + + + args + + A list of variable names. + + + + query-expression + + An sql + expression that represents an SQL + query which is expected to return a (possibly empty) + result set, where each tuple has as many attributes as + function takes arguments. + + + + database + + A + database + object. This will default to + *default-database*. + + + + body + + A body of Lisp code, like in a + destructuring-bind form. + + + + + + Description + Executes the body of code + repeatedly with the variable names in + args bound to the attributes of each + tuple in the result set returned by executing the SQL + query-expression on the + database specified. + The body of code is executed in a block named + nil which may be returned from prematurely + via return or + return-from. In this case the result + of evaluating the do-query form will be + the one supplied to return or + return-from. Otherwise the result will + be nil. + The body of code appears also is if wrapped in a + destructuring-bind form, thus allowing + declarations at the start of the body, especially those + pertaining to the bindings of the variables named in + args. + + + Examples + +(do-query ((salary name) "select salary,name from simple") + (format t "~30A gets $~2,5$~%" name (read-from-string salary))) +>> Mai, Pierre gets $10000.00 +>> Hacker, Random J. gets $08000.50 +=> NIL + +(do-query ((salary name) "select salary,name from simple") + (return (cons salary name))) +=> ("10000.00" . "Mai, Pierre") + + + + Side Effects + Whatever effects the execution of the SQL query has + on the underlying database, if any. + + + Affected by + None. + + + Exceptional Situations + If the execution of the SQL query leads to any + errors, an error of type + maisql-sql-error is signalled. + If the number of variable names in + args and the number of attributes in + the tuples in the result set don't match up, an error is + signalled. + + + See Also + + + query + map-query + + + + + Notes + None. + + + + + LOOP-FOR-AS-TUPLES + Iterate over all the tuples of a + query via a loop clause + Loop Clause + + + Syntax + var [type-spec] being {each | the} {record | records | tuple | tuples} {in | of} query [from database] + + + Arguments and Values + + + var + + A d-var-spec, as defined in the + grammar for loop-clauses in the + ANSI Standard for Common Lisp. This allows for the + usual loop-style destructuring. + + + + type-spec + + An optional type-spec either + simple or destructured, as defined in the grammar for + loop-clauses in the ANSI Standard + for Common Lisp. + + + + query + + An sql + expression that represents an SQL + query which is expected to return a (possibly empty) + result set, where each tuple has as many attributes as + function takes arguments. + + + + database + + An optional + database + object. This will default to the value + of *default-database*. + + + + + + Description + This clause is an iteration driver for + loop, that binds the given variable + (possibly destructured) to the consecutive tuples (which are + represented as lists of attribute values) in the result set + returned by executing the SQL query + expression on the database + specified. + + + Examples + +(defvar *my-db* (connect '("dent" "newesim" "dent" "dent")) + "My database" +=> *MY-DB* +(loop with time-graph = (make-hash-table :test #'equal) + with event-graph = (make-hash-table :test #'equal) + for (time event) being the tuples of "select time,event from log" + from *my-db* + do + (incf (gethash time time-graph 0)) + (incf (gethash event event-graph 0)) + finally + (flet ((show-graph (k v) (format t "~40A => ~5D~%" k v))) + (format t "~&Time-Graph:~%===========~%") + (maphash #'show-graph time-graph) + (format t "~&~%Event-Graph:~%============~%") + (maphash #'show-graph event-graph)) + (return (values time-graph event-graph))) +>> Time-Graph: +>> =========== +>> D => 53000 +>> X => 3 +>> test-me => 3000 +>> +>> Event-Graph: +>> ============ +>> CLOS Benchmark entry. => 9000 +>> Demo Text... => 3 +>> doit-text => 3000 +>> C Benchmark entry. => 12000 +>> CLOS Benchmark entry => 32000 +=> #<EQUAL hash table, 3 entries {48350A1D}> +=> #<EQUAL hash table, 5 entries {48350FCD}> + + + + Side Effects + Whatever effects the execution of the SQL query has + on the underlying database, if any. + + + Affected by + None. + + + Exceptional Situations + If the execution of the SQL query leads to any + errors, an error of type + maisql-sql-error is signalled. + Otherwise, any of the exceptional situations of + loop applies. + + + See Also + + + query + map-query + do-query + + + + + Notes + None. + + + + + <symbol>CLSQL-SYS</symbol> + + This part gives a reference to all the symbols exported + from the package CLSQL-SYS, which are not also + exported from CLSQL. These symbols are part of + the interface for database back-ends, but not part of the normal + user-interface of &clsql;. + + This part has only one demonstration entry, since the + rest still has to be written. In the meantime, use the + source to understand the database back-end interface. + + + + + DATABASE-INITIALIZE-DATABASE-TYPE + Back-end part of initialize-database-type. + Generic Function + + + Syntax + database-initialize-database-type database-type => result + + + Arguments and Values + + + database-type + + A keyword indicating the database type to + initialize. + + + + result + + Either t if the initialization + succeeds or nil if it fails. + + + + + + Description + This generic function implements the main part of the + database type initialization performed by + initialize-database-type. After + initialize-database-type has checked + that the given database type has not been initialized + before, as indicated by + *initialized-database-types*, it will call + this function with the database type as it's sole + parameter. Database back-ends are required to define a + method on this generic function which is specialized via an + eql-specializer to the keyword representing their database + type. + Database back-ends shall indicate successful + initialization by returning t from their + method, and nil otherwise. Methods for + this generic function are allowed to signal errors of type + maisql-error or subtypes thereof. + They may also signal other types of conditions, if + appropriate, but have to document this. + + + Examples + + + + Side Effects + All necessary side effects to initialize the database + instance. + + + Affected By + None. + + + Exceptional Situations + Conditions of type maisql-error + or other conditions may be signalled, depending on the + database back-end. + + + See Also + + + initialize-database-type + *initialized-database-types* + + + + + Notes + None. + + + diff --git a/doc/sgml-docbook-4.1.cat b/doc/sgml-docbook-4.1.cat new file mode 100644 index 0000000..a4a8408 --- /dev/null +++ b/doc/sgml-docbook-4.1.cat @@ -0,0 +1,4 @@ +CATALOG /usr/share/sgml/sgml-iso-entities-8879.1986/catalog +CATALOG /usr/share/sgml/docbook/sgml-dtd-4.1/catalog +CATALOG /usr/share/sgml/openjade-1.3/catalog +CATALOG /usr/share/sgml/docbook/dsssl-stylesheets-1.64/catalog diff --git a/interfaces/aodbc/.cvsignore b/interfaces/aodbc/.cvsignore new file mode 100755 index 0000000..ca8d09f --- /dev/null +++ b/interfaces/aodbc/.cvsignore @@ -0,0 +1 @@ +.bin diff --git a/interfaces/aodbc/aodbc-package.cl b/interfaces/aodbc/aodbc-package.cl new file mode 100644 index 0000000..3bfaee8 --- /dev/null +++ b/interfaces/aodbc/aodbc-package.cl @@ -0,0 +1,31 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: aodbc-package.cl +;;;; Purpose: Package definition for CLSQL AODBC backend +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: aodbc-package.cl,v 1.1 2002/03/23 14:04:52 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) + +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :aodbc-v2)) +#-allegro (warn "This system requires Allegro's AODBC library to operate") + +(defpackage :clsql-aodbc + (:nicknames :aodbc) + (:use :common-lisp :clsql-sys) + (:export #:aodbc-database) + (:documentation "This is the CLSQL interface to Allegro's AODBC")) diff --git a/interfaces/aodbc/aodbc-sql.cl b/interfaces/aodbc/aodbc-sql.cl new file mode 100644 index 0000000..c1a74c9 --- /dev/null +++ b/interfaces/aodbc/aodbc-sql.cl @@ -0,0 +1,123 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: aodbc-sql.cl +;;;; Purpose: Low-level interface for CLSQL AODBC backend +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: aodbc-sql.cl,v 1.1 2002/03/23 14:04:52 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-aodbc) + + +(defmethod database-initialize-database-type ((database-type (eql :aodbc))) + t) + +(defclass aodbc-database (database) + ((aodbc-conn :accessor database-aodbc-conn :initarg :aodbc-conn))) + +(defmethod database-name-from-spec (connection-spec + (database-type (eql :aodbc))) + (check-connection-spec connection-spec database-type (dsn user password)) + (destructuring-bind (dsn user password) connection-spec + (declare (ignore password)) + (concatenate 'string dsn "/" user))) + +(defmethod database-connect (connection-spec (database-type (eql :aodbc))) + (check-connection-spec connection-spec database-type (dsn user password)) + (destructuring-bind (dsn user password) connection-spec + (handler-case + (make-instance 'aodbc-database + :name (database-name-from-spec connection-spec :aodbc) + :aodbc-conn + (dbi:connect :user user + :password password + :data-source-name dsn)) + (error () ;; Init or Connect failed + (error 'clsql-connect-error + :database-type database-type + :connection-spec connection-spec + :errno nil + :error "Connection failed"))))) + +(defmethod database-disconnect ((database aodbc-database)) + (dbi:disconnect (database-aodbc-conn database)) + (setf (database-aodbc-conn database) nil) + t) + +(defmethod database-query (query-expression (database aodbc-database)) + (handler-case + (dbi:sql query-expression :db (database-aodbc-conn database)) + (error () + (error 'clsql-sql-error + :database database + :expression query-expression + :errno nil + :error "Query failed")))) + +(defmethod database-execute-command (sql-expression + (database aodbc-database)) + (handler-case + (dbi:sql sql-expression :db (database-aodbc-conn database)) + (error () + (error 'clsql-sql-error + :database database + :expression sql-expression + :errno nil + :error "Execute command failed")))) + +(defstruct aodbc-result-set + (query nil) + (full-set nil)) + +(defmethod database-query-result-set (query-expression + (database aodbc-database) + &optional full-set) + (handler-case + (multiple-value-bind (query column-names) + (dbi:sql query-expression + :db (database-aodbc-conn database) + :row-count nil + :column-names t + :query t + ) + (values + (make-aodbc-result-set :query query :full-set full-set) + (length column-names) + nil ;; not able to return number of rows with aodbc + )) + (error () + (error 'clsql-sql-error + :database database + :expression query-expression + :errno nil + :error "Query result set failed")))) + +(defmethod database-dump-result-set (result-set (database aodbc-database)) + (dbi:close-query (aodbc-result-set-query result-set)) + t) + +(defmethod database-store-next-row (result-set + (database aodbc-database) + list) + (let ((row (dbi:fetch-row (aodbc-result-set-query result-set) nil 'eof))) + (if (eq row 'eof) + nil + (progn + (loop for elem in row + for rest on list + do + (setf (car rest) elem)) + list)))) + + diff --git a/interfaces/mysql/.cvsignore b/interfaces/mysql/.cvsignore new file mode 100755 index 0000000..4fe5149 --- /dev/null +++ b/interfaces/mysql/.cvsignore @@ -0,0 +1,4 @@ +.bin +clsql-mysql.o +clsql-mysql.so + diff --git a/interfaces/mysql/Makefile b/interfaces/mysql/Makefile new file mode 100644 index 0000000..8452ef6 --- /dev/null +++ b/interfaces/mysql/Makefile @@ -0,0 +1,59 @@ +# -*- Mode: Makefile -*- +########################################################################### +# FILE IDENTIFICATION +# +# Name: Makefile +# Purpose: Makefile for the CLSQL UFFI helper package +# Programer: Kevin M. Rosenberg +# Date Started: Mar 2002 +# +# CVS Id: $Id: Makefile,v 1.1 2002/03/23 14:04:52 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. +########################################################################### + + +# These variables are correct for GCC +# you'll need to modify these for other compilers +CC=gcc +SHARED_CC_OPT=-fpic +SHARED_LD_OPT=-shared + +# If you are using Solaris, these are the correct values +# for creating a shared library +#CC=cc +#SHARED_CC_OPT=-KPIC +#SHARED_LD_OPT=-G + +# Set to the directory where you have installed mysql's library +#MYSQL_DIR=/usr +MYSQL_DIR=/opt/mysql + +MYSQL_LIB=${MYSQL_DIR}/lib/mysql +MYSQL_LIB_FILE=${MYSQL_LIB}/libmysqlclient.so +MYSQL_INCLUDE=${MYSQL_DIR}/include/mysql + +# Nothing to configure beyond this point + +BASE=clsql-mysql +SRC=${BASE}.c +OBJECT=${BASE}.o +LIB=${BASE}.so + +all: ${LIB} + +${LIB}: ${SRC} ${MYSQL_LIB_FILE} + ${CC} ${SHARED_CC_OPT} -I ${MYSQL_INCLUDE} -c ${SRC} -o ${OBJECT} + ld ${SHARED_LD_OPT} ${OBJECT} ${MYSQL_LIB_FILE} -o ${LIB} + @rm ${OBJECT} + +clean: + rm -f ${LIB} + +realclean: clean + rm -f *~ + diff --git a/interfaces/mysql/Makefile.msvc b/interfaces/mysql/Makefile.msvc new file mode 100644 index 0000000..7819801 --- /dev/null +++ b/interfaces/mysql/Makefile.msvc @@ -0,0 +1,42 @@ +# -*- Mode: Makefile -*- +########################################################################### +# FILE IDENTIFICATION +# +# Name: Makefile.msvc +# Purpose: Makefile for the CLSQL UFFI helper package (MSVC) +# Programer: Kevin M. Rosenberg +# Date Started: Mar 2002 +# +# CVS Id: $Id: Makefile.msvc,v 1.1 2002/03/23 14:04:52 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. +########################################################################### + + +BASE=clsql-mysql + +# Set to the directory where you have installed mysql's library +MYSQL_DIR=c:/mysql + +MYSQL_LIB_DIR=$(MYSQL_DIR)/lib/opt +MYSQL_LIB_FILE=$(MYSQL_LIB_DIR)/Libmysql.lib +MYSQL_INCLUDE=$(MYSQL_DIR)/include + +# Nothing to configure beyond here + +SRC=$(BASE).c +OBJ=$(BASE).obj +DLL=$(BASE).dll + +$(DLL): $(SRC) $(MYSQL_LIB_FILE) + cl /MD /LD -D_MT /DWIN32=1 /D__LCC__=1 /I$(MYSQL_INCLUDE) $(SRC) $(MYSQL_LIB_FILE) + del $(OBJ) $(BASE).exp + +clean: + del /q $(DLL) + + diff --git a/interfaces/mysql/clsql-mysql.c b/interfaces/mysql/clsql-mysql.c new file mode 100644 index 0000000..7557589 --- /dev/null +++ b/interfaces/mysql/clsql-mysql.c @@ -0,0 +1,90 @@ +/**************************************************************************** + * FILE IDENTIFICATION + * + * Name: mysql-helper.cl + * Purpose: Helper functions for mysql.cl to handle 64-bit parts of API + * Programmer: Kevin M. Rosenberg + * Date Started: Mar 2002 + * + * $Id: clsql-mysql.c,v 1.1 2002/03/23 14:04:52 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. + ***************************************************************************/ + +#ifdef WIN32 +#include + +BOOL WINAPI DllEntryPoint(HINSTANCE hinstdll, DWORD fdwReason, + LPVOID lpvReserved) +{ + return 1; +} + +#define DLLEXPORT __declspec(dllexport) + +#else +#define DLLEXPORT +#endif + + +#include + +/* Need to assemble a 64-bit integer to send to MySQL */ +DLLEXPORT +void +clsql_mysql_data_seek (MYSQL_RES* res, unsigned int offset_high32, + unsigned int offset_low32) +{ + my_ulonglong offset; + + offset = offset_high32; + offset = offset << 32; + offset += offset_low32; + + mysql_data_seek (res, offset); +} + +/* The following functions are used to return 64-bit integers to Lisp. + They return the 32-bit low part and store in upper 32-bits in a + located sent via a pointer */ + +const unsigned int bitmask_32bits = 0xFFFFFFFF; + +#define lower_32bits(int64) ((unsigned int) int64 & bitmask_32bits) +#define upper_32bits(int64) ((unsigned int) (int64 >> 32)) + +DLLEXPORT +unsigned int +clsql_mysql_num_rows (MYSQL_RES* res, unsigned int* pHigh32) +{ + my_ulonglong nRows = mysql_num_rows (res); + *pHigh32 = upper_32bits(nRows); + return lower_32bits(nRows); +} + +DLLEXPORT +unsigned int +clsql_mysql_affected_rows (MYSQL* res, unsigned int* pHigh32) +{ + my_ulonglong nAffected = mysql_affected_rows (res); + *pHigh32 = upper_32bits(nAffected); + return lower_32bits(nAffected); +} + +DLLEXPORT +unsigned int +clsql_mysql_insert_id (MYSQL* mysql, unsigned int* pHigh32) +{ + my_ulonglong insert_id = mysql_insert_id (mysql); + *pHigh32 = upper_32bits(insert_id); + return lower_32bits(insert_id); +} + + + + + diff --git a/interfaces/mysql/mysql-loader.cl b/interfaces/mysql/mysql-loader.cl new file mode 100644 index 0000000..df0bd64 --- /dev/null +++ b/interfaces/mysql/mysql-loader.cl @@ -0,0 +1,69 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: mysql-loader.sql +;;;; Purpose: MySQL library loader using UFFI +;;;; Programmers: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: mysql-loader.cl,v 1.1 2002/03/23 14:04:52 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 :mysql) + +;;;; Modified by Kevin Rosenberg +;;;; - probe potential directories to find library +;;;; - Changed from CMUCL functions to UFFI to +;;;; -- prevent library from being loaded multiple times +;;;; -- support Allegro CL and Lispworks + +(defvar *clsql-mysql-library-filename* + (translate-logical-pathname + #+(or linux unix) "CLSQL:interfaces;mysql;clsql-mysql.so" + #+(or mswindows win32) "CLSQL:interfaces;mysql;clsql-mysql.dll" + )) + +(defvar *mysql-library-filename* + (cond + ((probe-file "/opt/mysql/lib/mysql/libmysqlclient.so") + "/opt/mysql/lib/mysql/libmysqlclient.so") + ((probe-file "/usr/local/lib/libmysqlclient.so") + "/usr/local/lib/libmysqlclient.so") + ((probe-file "/usr/lib/libmysqlclient.so") + "/usr/lib/libmysqlclient.so") + #+(or win32 mswindows) + ((probe-file "c:/mysql/lib/opt/libmysql.dll") + "c:/mysql/lib/opt/libmysql.dll") + (t + (warn "Can't find MySQL client library to load."))) + "Location where the MySQL client library is to be found.") + +(defvar *mysql-supporting-libraries* '("c") + "Used only by CMU. List of library flags needed to be passed to ld to +load the MySQL client library succesfully. If this differs at your site, +set to the right path before compiling or loading the system.") + + + +(defmethod database-type-load-foreign ((database-type (eql :mysql))) + (uffi:load-foreign-library *mysql-library-filename* + :module "mysql" + :supporting-libraries + *mysql-supporting-libraries*) + (uffi:load-foreign-library *clsql-mysql-library-filename* + :module "clsql-mysql" + :supporting-libraries + (append *mysql-supporting-libraries*))) + + +(database-type-load-foreign :mysql) + + diff --git a/interfaces/mysql/mysql-package.cl b/interfaces/mysql/mysql-package.cl new file mode 100644 index 0000000..450efc2 --- /dev/null +++ b/interfaces/mysql/mysql-package.cl @@ -0,0 +1,125 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: mysql-package.cl +;;;; Purpose: Package definition for low-level MySQL interface +;;;; Programmers: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: mysql-package.cl,v 1.1 2002/03/23 14:04:52 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 :mysql + (:use :common-lisp) + (:export + #:mysql-socket + #:mysql-book + #:mysql-byte + #:mysql-net-type + #:mysql-net-type#tcp-ip + #:mysql-net-type#socket + #:mysql-net-type#named-pipe + #:mysql-net + #:mysql-used-mem + #:mysql-mem-root + #:mysql-field-types + #:mysql-field-types#decimal + #:mysql-field-types#tiny + #:mysql-field-types#short + #:mysql-field-types#long + #:mysql-field-types#float + #:mysql-field-types#double + #:mysql-field-types#null + #:mysql-field-types#timestamp + #:mysql-field-types#longlong + #:mysql-field-types#int24 + #:mysql-field-types#date + #:mysql-field-types#time + #:mysql-field-types#datetime + #:mysql-field-types#year + #:mysql-field-types#newdate + #:mysql-field-types#enum + #:mysql-field-types#tiny-blob + #:mysql-field-types#medium-blob + #:mysql-field-types#long-blob + #:mysql-field-types#blob + #:mysql-field-types#var-string + #:mysql-field-types#string + #:mysql-field + #:mysql-row + #:mysql-field-offset + #:mysql-row-offset + #:mysql-data + #:mysql-options + #:mysql-mysql-option + #:mysql-mysql-option#connect-timeout + #:mysql-mysql-option#compress + #:mysql-mysql-option#named-pipe + #:mysql-mysql-option#init-command + #:mysql-mysql-option#read-default-file + #:mysql-mysql-option#read-default-group + #:mysql-status + #:mysql-status#ready + #:mysql-status#get-ready + #:mysql-status#use-result + #:mysql-mysql + #:mysql-mysql-res + + ;; functions + #:mysql-init + #:mysql-connect + #:mysql-real-connect + #:mysql-close + #:mysql-select-db + #:mysql-query + #:mysql-real-query + #:mysql-create-db + #:mysql-drop-db + #:mysql-shutdown + #:mysql-dump-debug-info + #:mysql-refresh + #:mysql-kill + #:mysql-ping + #:mysql-stat + #:mysql-get-server-info + #:mysql-get-client-info + #:mysql-get-host-info + #:mysql-get-proto-info + #:mysql-list-dbs + #:mysql-list-tables + #:mysql-list-fields + #:mysql-list-processes + #:mysql-store-result + #:mysql-use-result + #:mysql-options + #:mysql-free-result + #:mysql-row-seek + #:mysql-field-seek + #:mysql-fetch-row + #:mysql-fetch-lengths + #:mysql-fetch-field + #:mysql-escape-string + #:mysql-debug + #:mysql-num-rows + #:mysql-num-fields + #:mysql-affected-rows + #:mysql-insert-id + #:mysql-eof + #:mysql-error + #:mysql-error-string + #:mysql-errno + #:mysql-info + #:mysql-info-string + #:mysql-data-seek + ) + (:documentation "This is the low-level interface MySQL.")) diff --git a/interfaces/mysql/mysql-sql.cl b/interfaces/mysql/mysql-sql.cl new file mode 100644 index 0000000..20cac08 --- /dev/null +++ b/interfaces/mysql/mysql-sql.cl @@ -0,0 +1,191 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: mysql-sql.cl +;;;; Purpose: High-level MySQL interface using UFFI +;;;; Programmers: Kevin M. Rosenberg based on +;;;; Original code by Pierre R. Mai +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: mysql-sql.cl,v 1.1 2002/03/23 14:04:52 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))) + +;;;; Modified by Kevin Rosenberg, Feb 20002 +;;;; -- Added support for Allegro CL and Lispworks using UFFI layer +;;;; -- Changed database-connect to use mysql-real-connect. This way, +;;;; can avoid using double (unwind-protect) +;;;; -- Changed database-connect to have MySQL library allocate space +;;;; for MYSQL structure. This will make the code more robust in +;;;; the event that MySQL library changes the size of the mysql-mysql +;;;; structure. + +(defpackage :clsql-mysql + (:use :common-lisp :clsql-sys :mysql) + (:documentation "This is the CLSQL interface to MySQL.")) + +(in-package :clsql-mysql) + +(defmethod database-initialize-database-type ((database-type (eql :mysql))) + t) + +(uffi:def-type mysql-mysql-ptr-def (* mysql-mysql)) +(uffi:def-type mysql-row-def mysql-row) +(uffi:def-type mysql-mysql-res-ptr-def (* mysql-mysql-res)) + +(defclass mysql-database (database) + ((mysql-ptr :accessor database-mysql-ptr :initarg :mysql-ptr + :type mysql-mysql-ptr-def))) + +(defmethod database-name-from-spec (connection-spec (database-type (eql :mysql))) + (check-connection-spec connection-spec database-type (host db user password)) + (destructuring-bind (host db user password) connection-spec + (declare (ignore password)) + (concatenate 'string host "/" db "/" user))) + +(defmethod database-connect (connection-spec (database-type (eql :mysql))) + (check-connection-spec connection-spec database-type (host db user password)) + (destructuring-bind (host db user password) connection-spec + (let ((mysql-ptr (mysql-init (uffi:make-null-pointer 'mysql-mysql))) + (socket nil)) + (if (uffi:null-pointer-p mysql-ptr) + (error 'clsql-connect-error + :database-type database-type + :connection-spec connection-spec + :errno (mysql-errno mysql-ptr) + :error (mysql-error-string mysql-ptr)) + (uffi:with-cstring (host-native host) + (uffi:with-cstring (user-native user) + (uffi:with-cstring (password-native password) + (uffi:with-cstring (db-native db) + (uffi:with-cstring (socket-native socket) + (let ((error-occurred nil)) + (unwind-protect + (if (uffi:null-pointer-p + (mysql-real-connect + mysql-ptr host-native user-native password-native + db-native 0 socket-native 0)) + (progn + (setq error-occurred t) + (error 'clsql-connect-error + :database-type database-type + :connection-spec connection-spec + :errno (mysql-errno mysql-ptr) + :error (mysql-error-string mysql-ptr))) + (make-instance 'mysql-database + :name (database-name-from-spec connection-spec + database-type) + :mysql-ptr mysql-ptr)) + (when error-occurred (mysql-close mysql-ptr))))))))))))) + + +(defmethod database-disconnect ((database mysql-database)) + (mysql-close (database-mysql-ptr database)) + (setf (database-mysql-ptr database) nil) + t) + + +(defstruct mysql-result-set + (res-ptr (uffi:make-null-pointer 'mysql-mysql-res) + :type mysql-mysql-res-ptr-def) + (full-set nil)) + +(defmethod database-dump-result-set (result-set (database mysql-database)) + (mysql-free-result (mysql-result-set-res-ptr result-set)) + t) + + +(defmethod database-store-next-row (result-set (database mysql-database) list) + (let* ((res-ptr (mysql-result-set-res-ptr result-set)) + (row (mysql-fetch-row res-ptr))) + (declare (type mysql-mysql-res-ptr-def res-ptr) + (type mysql-row-def row)) + (unless (uffi:null-pointer-p row) + (loop for i from 0 below (mysql-num-fields res-ptr) + for rest on list + do + (setf (car rest) + (uffi:convert-from-foreign-string (uffi:deref-array row 'mysql-row i)))) + list))) + + +(defmethod database-execute-command (sql-expression (database mysql-database)) + (uffi:with-cstring (sql-native sql-expression) + (let ((mysql-ptr (database-mysql-ptr database))) + (declare (type mysql-mysql-ptr-def mysql-ptr)) + (if (zerop (mysql-query mysql-ptr sql-native)) + t + (error 'clsql-sql-error + :database database + :expression sql-expression + :errno (mysql-errno mysql-ptr) + :error (mysql-error-string mysql-ptr)))))) + + + +(defmethod database-query (query-expression (database mysql-database)) + (with-slots (mysql-ptr) database + (uffi:with-cstring (query-native query-expression) + (if (zerop (mysql-query mysql-ptr query-native)) + (let ((res-ptr (mysql-use-result mysql-ptr))) + (if res-ptr + (unwind-protect + (loop for row = (mysql-fetch-row res-ptr) + until (uffi:null-pointer-p row) + collect + (loop for i from 0 below (mysql-num-fields res-ptr) + collect + (uffi:convert-from-cstring + (uffi:deref-array row 'mysql-row i)))) + (mysql-free-result res-ptr)) + (error 'clsql-sql-error + :database database + :expression query-expression + :errno (mysql-errno mysql-ptr) + :error (mysql-error-string mysql-ptr)))) + (error 'clsql-sql-error + :database database + :expression query-expression + :errno (mysql-errno mysql-ptr) + :error (mysql-error-string mysql-ptr)))))) + + +(defmethod database-query-result-set (query-expression + (database mysql-database) + &optional full-set) + (uffi:with-cstring (query-native query-expression) + (let ((mysql-ptr (database-mysql-ptr database))) + (declare (type mysql-mysql-ptr-def mysql-ptr)) + (if (zerop (mysql-query mysql-ptr query-native)) + (let ((res-ptr (if full-set + (mysql-store-result mysql-ptr) + (mysql-use-result mysql-ptr)))) + (declare (type mysql-mysql-res-ptr-def res-ptr)) + (if (not (uffi:null-pointer-p res-ptr)) + (if full-set + (values (make-mysql-result-set :res-ptr res-ptr :full-set t) + (mysql-num-fields res-ptr) + (mysql-num-rows res-ptr)) + (values (make-mysql-result-set :res-ptr res-ptr) + (mysql-num-fields res-ptr))) + (error 'clsql-sql-error + :database database + :expression query-expression + :errno (mysql-errno mysql-ptr) + :error (mysql-error-string mysql-ptr)))) + (error 'clsql-sql-error + :database database + :expression query-expression + :errno (mysql-errno mysql-ptr) + :error (mysql-error-string mysql-ptr)))))) + + diff --git a/interfaces/mysql/mysql-uffi.cl b/interfaces/mysql/mysql-uffi.cl new file mode 100644 index 0000000..db33d9d --- /dev/null +++ b/interfaces/mysql/mysql-uffi.cl @@ -0,0 +1,579 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: mysql.cl +;;;; Purpose: Low-level MySQL interface using UFFI +;;;; Programmers: Kevin M. Rosenberg based on +;;;; Original code by Pierre R. Mai +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: mysql-uffi.cl,v 1.1 2002/03/23 14:04:53 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 :mysql) + +;;;; Modifications from original code +;;;; - Updated C-structures to conform to structures in MySQL 3.23.46 +;;;; - Changed from CMUCL interface to UFFI +;;;; - Added and call a C-helper file to support 64-bit integers +;;;; that are used in a few routines. +;;;; - Removed all references to interiors of C-structions, this will +;;;; increase robustness when MySQL's internal structures change. + +;;;; Type definitions + +;;; Basic Types + +(uffi:def-foreign-type mysql-socket :int) +(uffi:def-foreign-type mysql-bool :char) +(uffi:def-foreign-type mysql-byte :unsigned-char) + +(uffi:def-enum mysql-net-type + (:tcp-ip + :socket + :named-pipe)) + +(uffi:def-struct mysql-net + (vio :pointer-void) + (fd mysql-socket) + (fcntl :int) + (buff (* :unsigned-char)) + (buff-end (* :unsigned-char)) + (write-pos (* :unsigned-char)) + (read-pos (* :unsigned-char)) + (last-error (:array :char 200)) + (last-errno :unsigned-int) + (max-packet :unsigned-int) + (timeout :unsigned-int) + (pkt-nr :unsigned-int) + (error mysql-bool) + (return-errno mysql-bool) + (compress mysql-bool) + (no-send-ok mysql-bool) + (remain-in-buf :unsigned-long) + (length :unsigned-long) + (buf-length :unsigned-long) + (where-b :unsigned-long) + (return-status (* :unsigned-int)) + (reading-or-writing :unsigned-char) + (save-char :char)) + +;;; Mem-Root +(uffi:def-struct mysql-used-mem + (next :pointer-self) + (left :unsigned-int) + (size :unsigned-int)) + +(uffi:def-struct mysql-mem-root + (free (* mysql-used-mem)) + (used (* mysql-used-mem)) + (pre-alloc (* mysql-used-mem)) + (min-alloc :unsigned-int) + (block-size :unsigned-int) + (error-handler :pointer-void)) + +;;; MYSQL-FIELD +(uffi:def-enum mysql-field-types + (:decimal + :tiny + :short + :long + :float + :double + :null + :timestamp + :longlong + :int24 + :date + :time + :datetime + :year + :newdate + (:enum 247) + (:set 248) + (:tiny-blob 249) + (:medium-blob 250) + (:long-blob 251) + (:blob 252) + (:var-string 253) + (:string 254))) + +(uffi:def-struct mysql-field + (name (* :char)) + (table (* :char)) + (def (* :char)) + (type mysql-field-types) + (length :unsigned-int) + (max-length :unsigned-int) + (flags :unsigned-int) + (decimals :unsigned-int)) + +;;; MYSQL-ROWS + +(uffi:def-array-pointer mysql-row (* :unsigned-char)) + +(uffi:def-foreign-type mysql-field-offset :unsigned-int) + +(uffi:def-struct mysql-rows + (next :pointer-self) + (data mysql-row)) + +(uffi:def-foreign-type mysql-row-offset (* mysql-rows)) + +(uffi:def-struct mysql-data + (rows-high32 :unsigned-long) + (rows-low32 :unsigned-long) + (fields :unsigned-int) + (data (* mysql-rows)) + (alloc mysql-mem-root)) + +;;; MYSQL +(uffi:def-struct mysql-options + (connect-timeout :unsigned-int) + (client-flag :unsigned-int) + (compress mysql-bool) + (named-pipe mysql-bool) + (port :unsigned-int) + (host (* :char)) + (init-command (* :char)) + (user (* :char)) + (password (* :char)) + (unix-socket (* :char)) + (db (* :char)) + (my-cnf-file (* :char)) + (my-cnf-group (* :char)) + (charset-dir (* :char)) + (charset-name (* :char)) + (use-ssl mysql-bool) + (ssl-key (* :char)) + (ssl-cert (* :char)) + (ssl-ca (* :char)) + (ssl-capath (* :char))) + +(uffi:def-enum mysql-option + (:connect-timeout + :compress + :named-pipe + :init-command + :read-default-file + :read-default-group)) + +(uffi:def-enum mysql-status + (:ready + :get-result + :use-result)) + +(uffi:def-struct mysql-mysql + (net mysql-net) + (connected-fd (* :char)) + (host (* :char)) + (user (* :char)) + (passwd (* :char)) + (unix-socket (* :char)) + (server-version (* :char)) + (host-info (* :char)) + (info (* :char)) + (db (* :char)) + (port :unsigned-int) + (client-flag :unsigned-int) + (server-capabilities :unsigned-int) + (protocol-version :unsigned-int) + (field-count :unsigned-int) + (server-status :unsigned-int) + (thread-id :unsigned-long) + (affected-rows-high32 :unsigned-long) + (affected-rows-low32 :unsigned-long) + (insert-id-high32 :unsigned-long) + (insert-id-low32 :unsigned-long) + (extra-info-high32 :unsigned-long) + (extra-info-low32 :unsigned-long) + (packet-length :unsigned-long) + (status mysql-status) + (fields (* mysql-field)) + (field-alloc mysql-mem-root) + (free-me mysql-bool) + (reconnect mysql-bool) + (options mysql-options) + (scramble-buff (:array :char 9)) + (charset :pointer-void) + (server-language :unsigned-int)) + + +;;; MYSQL-RES +(uffi:def-struct mysql-mysql-res + (row-count-high32 :unsigned-long) + (row-count-low32 :unsigned-long) + (field-count :unsigned-int) + (current-field :unsigned-int) + (fields (* mysql-field)) + (data (* mysql-data)) + (data-cursor (* mysql-rows)) + (field-alloc mysql-mem-root) + (row mysql-row) + (current-row mysql-row) + (lengths (* :unsigned-long)) + (handle (* mysql-mysql)) + (eof mysql-bool)) + +;;;; The Foreign C routines +(declaim (inline mysql-init)) +(uffi:def-function "mysql_init" + ((mysql (* mysql-mysql))) + :module "mysql" + :returning (* mysql-mysql)) + +(declaim (inline mysql-connect)) +(uffi:def-function "mysql_connect" + ((mysql (* mysql-mysql)) + (host :cstring) + (user :cstring) + (passwd :cstring)) + :module "mysql" + :returning (* mysql-mysql)) + +(declaim (inline mysql-real-connect)) +(uffi:def-function "mysql_real_connect" + ((mysql (* mysql-mysql)) + (host :cstring) + (user :cstring) + (passwd :cstring) + (db :cstring) + (port :unsigned-int) + (unix-socket :cstring) + (clientflag :unsigned-int)) + :module "mysql" + :returning (* mysql-mysql)) + +(declaim (inline mysql-close)) +(uffi:def-function "mysql_close" + ((sock (* mysql-mysql))) + :module "mysql" + :returning :void) + +(declaim (inline mysql-select-db)) +(uffi:def-function "mysql_select_db" + ((mysql (* mysql-mysql)) + (db :cstring)) + :module "mysql" + :returning :int) + +(declaim (inline mysql-query)) +(uffi:def-function "mysql_query" + ((mysql (* mysql-mysql)) + (query :cstring)) + :module "mysql" + :returning :int) + + ;;; I doubt that this function is really useful for direct Lisp usage, +;;; but it is here for completeness... + +(declaim (inline mysql-real-query)) +(uffi:def-function "mysql_real_query" + ((mysql (* mysql-mysql)) + (query :cstring) + (length :unsigned-int)) + :module "mysql" + :returning :int) + +(declaim (inline mysql-create-db)) +(uffi:def-function "mysql_create_db" + ((mysql (* mysql-mysql)) + (db :cstring)) + :module "mysql" + :returning :int) + +(declaim (inline mysql-drop-db)) +(uffi:def-function "mysql_drop_db" + ((mysql (* mysql-mysql)) + (db :cstring)) + :module "mysql" + :returning :int) + +(declaim (inline mysql-shutdown)) +(uffi:def-function "mysql_shutdown" + ((mysql (* mysql-mysql))) + :module "mysql" + :returning :int) + +(declaim (inline mysql-dump-debug-info)) +(uffi:def-function "mysql_dump_debug_info" + ((mysql (* mysql-mysql))) + :module "mysql" + :returning :int) + +(declaim (inline mysql-refresh)) +(uffi:def-function "mysql_refresh" + ((mysql (* mysql-mysql)) + (refresh-options :unsigned-int)) + :module "mysql" + :returning :int) + +(declaim (inline mysql-kill)) +(uffi:def-function "mysql_kill" + ((mysql (* mysql-mysql)) + (pid :unsigned-long)) + :module "mysql" + :returning :int) + +(declaim (inline mysql-ping)) +(uffi:def-function "mysql_ping" + ((mysql (* mysql-mysql))) + :module "mysql" + :returning :int) + +(declaim (inline mysql-stat)) +(uffi:def-function "mysql_stat" + ((mysql (* mysql-mysql))) + :module "mysql" + :returning :cstring) + +(declaim (inline mysql-get-server-info)) +(uffi:def-function "mysql_get_server_info" + ((mysql (* mysql-mysql))) + :module "mysql" + :returning :cstring) + +(declaim (inline mysql-get-client-info)) +(uffi:def-function "mysql_get_client_info" + () + :module "mysql" + :returning :cstring) + +(declaim (inline mysql-get-host-info)) +(uffi:def-function "mysql_get_host_info" + ((mysql (* mysql-mysql))) + :module "mysql" + :returning :cstring) + +(declaim (inline mysql-get-proto-info)) +(uffi:def-function "mysql_get_proto_info" + ((mysql (* mysql-mysql))) + :module "mysql" + :returning :unsigned-int) + +(declaim (inline mysql-list-dbs)) +(uffi:def-function "mysql_list_dbs" + ((mysql (* mysql-mysql)) + (wild :cstring)) + :module "mysql" + :returning (* mysql-mysql-res)) + +(declaim (inline mysql-list-tables)) +(uffi:def-function "mysql_list_tables" + ((mysql (* mysql-mysql)) + (wild :cstring)) + :module "mysql" + :returning (* mysql-mysql-res)) + +(declaim (inline mysql-list-fields)) +(uffi:def-function "mysql_list_fields" + ((mysql (* mysql-mysql)) + (table :cstring) + (wild :cstring)) + :module "mysql" + :returning (* mysql-mysql-res)) + +(declaim (inline mysql-list-processes)) +(uffi:def-function "mysql_list_processes" + ((mysql (* mysql-mysql))) + :module "mysql" + :returning (* mysql-mysql-res)) + +(declaim (inline mysql-store-result)) +(uffi:def-function "mysql_store_result" + ((mysql (* mysql-mysql))) + :module "mysql" + :returning (* mysql-mysql-res)) + +(declaim (inline mysql-use-result)) +(uffi:def-function "mysql_use_result" + ((mysql (* mysql-mysql))) + :module "mysql" + :returning (* mysql-mysql-res)) + +(declaim (inline mysql-options)) +(uffi:def-function "mysql_options" + ((mysql (* mysql-mysql)) + (option mysql-option) + (arg :cstring)) + :module "mysql" + :returning :int) + +(declaim (inline mysql-free-result)) +(uffi:def-function "mysql_free_result" + ((res (* mysql-mysql-res))) + :module "mysql" + :returning :void) + +(declaim (inline mysql-row-seek)) +(uffi:def-function "mysql_row_seek" + ((res (* mysql-mysql-res)) + (offset mysql-row-offset)) + :module "mysql" + :returning mysql-row-offset) + +(declaim (inline mysql-field-seek)) +(uffi:def-function "mysql_field_seek" + ((res (* mysql-mysql-res)) + (offset mysql-field-offset)) + :module "mysql" + :returning mysql-field-offset) + +(declaim (inline mysql-fetch-row)) +(uffi:def-function "mysql_fetch_row" + ((res (* mysql-mysql-res))) + :module "mysql" + :returning mysql-row) + +(declaim (inline mysql-fetch-lengths)) +(uffi:def-function "mysql_fetch_lengths" + ((res (* mysql-mysql-res))) + :module "mysql" + :returning (* :unsigned-long)) + +(declaim (inline mysql-fetch-field)) +(uffi:def-function "mysql_fetch_field" + ((res (* mysql-mysql-res))) + :module "mysql" + :returning (* mysql-field)) + +(declaim (inline mysql-escape-string)) +(uffi:def-function "mysql_escape_string" + ((to :cstring) + (from :cstring) + (length :unsigned-int)) + :module "mysql" + :returning :unsigned-int) + +(declaim (inline mysql-debug)) +(uffi:def-function "mysql_debug" + ((debug :cstring)) + :module "mysql" + :returning :void) + +(declaim (inline clsql-mysql-num-rows)) +(uffi:def-function "clsql_mysql_num_rows" + ((res (* mysql-mysql-res)) + (p-high32 (* :unsigned-int))) + :module "clsql-mysql" + :returning :unsigned-int) + + +;;;; Equivalents of C Macro definitions for accessing various fields +;;;; in the internal MySQL Datastructures + +(uffi:def-constant +2^32+ 4294967296) +(uffi:def-constant +2^32-1+ (1- +2^32+)) + +(defmacro make-64-bit-integer (high32 low32) + `(+ ,low32 (* ,high32 +2^32+))) + +(declaim (inline mysql-num-rows)) +(defun mysql-num-rows (res) + (uffi:with-foreign-object (p-high32 :unsigned-int) + (let ((low32 (clsql-mysql-num-rows res p-high32)) + (high32 (uffi:deref-pointer p-high32 :unsigned-int))) + (if (zerop high32) + low32 + (make-64-bit-integer high32 low32))))) + +(uffi:def-function "clsql_mysql_affected_rows" + ((mysql (* mysql-mysql)) + (p-high32 (* :unsigned-int))) + :returning :unsigned-int + :module "clsql-mysql") + +(defun mysql-affected-rows (mysql) + (uffi:with-foreign-object (p-high32 :unsigned-int) + (let ((low32 (clsql-mysql-affected-rows mysql p-high32)) + (high32 (uffi:deref-pointer p-high32 :unsigned-int))) + (if (zerop high32) + low32 + (make-64-bit-integer high32 low32))))) + +(uffi:def-function "clsql_mysql_insert_id" + ((res (* mysql-mysql)) + (p-high32 (* :unsigned-int))) + :returning :unsigned-int + :module "clsql-mysql") + +(defun mysql-insert-id (mysql) + (uffi:with-foreign-object (p-high32 :unsigned-int) + (let ((low32 (clsql-mysql-insert-id mysql p-high32)) + (high32 (uffi:deref-pointer p-high32 :unsigned-int))) + (if (zerop high32) + low32 + (make-64-bit-integer high32 low32))))) + + +(declaim (inline mysql-num-fields)) +(uffi:def-function "mysql_num_fields" + ((res (* mysql-mysql-res))) + :returning :unsigned-int + :module "mysql") + +(declaim (inline clsql-mysql-eof)) +(uffi:def-function ("mysql_eof" clsql-mysql-eof) + ((res (* mysql-mysql-res))) + :returning :char + :module "mysql") + +(declaim (inline mysql-eof)) +(defun mysql-eof (res) + (if (zerop (clsql-mysql-eof res)) + nil + t)) + +(declaim (inline mysql-error)) +(uffi:def-function ("mysql_error" mysql-error) + ((mysql (* mysql-mysql))) + :returning :cstring + :module "mysql") + +(declaim (inline mysql-error-string)) +(defun mysql-error-string (mysql) + (uffi:convert-from-cstring (mysql-error mysql))) + +(declaim (inline mysql-errno)) +(uffi:def-function "mysql_errno" + ((mysql (* mysql-mysql))) + :returning :unsigned-int + :module "mysql") + +(declaim (inline mysql-info)) +(uffi:def-function ("mysql_info" mysql-info) + ((mysql (* mysql-mysql))) + :returning :cstring + :module "mysql") + +(declaim (inline mysql-info-string)) +(defun mysql-info-string (mysql) + (uffi:convert-from-cstring (mysql-info mysql))) + +(declaim (inline clsql-mysql-data-seek)) +(uffi:def-function "clsql_mysql_data_seek" + ((res (* mysql-mysql-res)) + (offset-high32 :unsigned-int) + (offset-low32 :unsigned-int)) + :module "clsql-mysql" + :returning :void) + + +(declaim (inline split-64bit-integer)) +(defun split-64bit-integer (int64) + (values (ash int64 -32) (logand int64 +2^32-1+))) + +(defun mysql-data-seek (res offset) + (multiple-value-bind (high32 low32) (split-64bit-integer offset) + (clsql-mysql-data-seek res high32 low32))) + diff --git a/interfaces/mysql/testing/mysql-struct-size.cc b/interfaces/mysql/testing/mysql-struct-size.cc new file mode 100644 index 0000000..cd0c267 --- /dev/null +++ b/interfaces/mysql/testing/mysql-struct-size.cc @@ -0,0 +1,7 @@ +#include +#include "/opt/mysql/include/mysql/mysql.h" + +int main (int argc, char** argv) +{ + printf ("Size of MYSQL struct: %ld\n", sizeof (MYSQL)); +} diff --git a/interfaces/mysql/testing/mysql-struct-size.cl b/interfaces/mysql/testing/mysql-struct-size.cl new file mode 100644 index 0000000..60dfd92 --- /dev/null +++ b/interfaces/mysql/testing/mysql-struct-size.cl @@ -0,0 +1,11 @@ +(in-package :mysql) + +#+lispworks +(progn + (setq c (fli:allocate-foreign-object :type 'mysql-mysql)) + (format t "~&Size MYSQL structure: ~d" (fli:pointer-element-size c))) +#+allegro +(progn + (setq c (ff:allocate-fobject 'mysql-mysql :foreign)) + (format t "~&Size MYSQL structure: ~A" c)) + diff --git a/interfaces/postgresql-socket/.cvsignore b/interfaces/postgresql-socket/.cvsignore new file mode 100755 index 0000000..ca8d09f --- /dev/null +++ b/interfaces/postgresql-socket/.cvsignore @@ -0,0 +1 @@ +.bin diff --git a/interfaces/postgresql-socket/postgresql-socket-package.cl b/interfaces/postgresql-socket/postgresql-socket-package.cl new file mode 100644 index 0000000..b9ccd8b --- /dev/null +++ b/interfaces/postgresql-socket/postgresql-socket-package.cl @@ -0,0 +1,54 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: postgresql-socket-package.cl +;;;; Purpose: Package definition for PostgreSQL interface using sockets +;;;; Programmers: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: postgresql-socket-package.cl,v 1.1 2002/03/23 14:04:53 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) + +(in-package :cl-user) + +(defpackage :postgresql-socket + (:use :common-lisp) + (:export #:+crypt-library+ + #:postgresql-condition + #:postgresql-condition-connection + #:postgresql-condition-message + #:postgresql-error + #:postgresql-fatal-error + #:postgresql-login-error + #:postgresql-warning + #:postgresql-notification + #:postgresql-connection + #:postgresql-connection-p + #:postgresql-cursor + #:postgresql-cursor-p + #:postgresql-cursor-connection + #:postgresql-cursor-name + #:postgresql-cursor-fields + #:+postgresql-server-default-port+ + #:open-postgresql-connection + #:reopen-postgresql-connection + #:close-postgresql-connection + #:postgresql-connection-open-p + #:ensure-open-postgresql-connection + #:start-query-execution + #:wait-for-query-results + #:read-cursor-row + #:copy-cursor-row + #:skip-cursor-row + )) + diff --git a/interfaces/postgresql-socket/postgresql-socket-sql.cl b/interfaces/postgresql-socket/postgresql-socket-sql.cl new file mode 100644 index 0000000..2654a89 --- /dev/null +++ b/interfaces/postgresql-socket/postgresql-socket-sql.cl @@ -0,0 +1,206 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: postgresql-socket-sql.sql +;;;; Purpose: High-level PostgreSQL interface using socket +;;;; Programmers: Kevin M. Rosenberg based on +;;;; Original code by Pierre R. Mai +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: postgresql-socket-sql.cl,v 1.1 2002/03/23 14:04:53 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) + + +(defpackage :clsql-postgresql-socket + (:use :common-lisp :clsql-sys :postgresql-socket) + (:export #:postgresql-socket-database) + (:documentation "This is the CLSQL socket interface to PostgreSQL.")) + +(in-package :clsql-postgresql-socket) + +(defun convert-to-clsql-warning (database condition) + (warn 'clsql-database-warning :database database + :message (postgresql-condition-message condition))) + +(defun convert-to-clsql-error (database expression condition) + (error 'clsql-sql-error :database database + :expression expression + :errno (type-of condition) + :error (postgresql-condition-message condition))) + +(defmacro with-postgresql-handlers + ((database &optional expression) + &body body) + (let ((database-var (gensym)) + (expression-var (gensym))) + `(let ((,database-var ,database) + (,expression-var ,expression)) + (handler-bind ((postgresql-warning + (lambda (c) + (convert-to-clsql-warning ,database-var c))) + (postgresql-error + (lambda (c) + (convert-to-clsql-error + ,database-var ,expression-var c)))) + ;; KMR - removed double @@ + ,@body)))) + +(defmethod database-initialize-database-type + ((database-type (eql :postgresql-socket))) + t) + +(defclass postgresql-socket-database (database) + ((connection :accessor database-connection :initarg :connection + :type postgresql-connection))) + +(defmethod database-name-from-spec + (connection-spec (database-type (eql :postgresql-socket))) + (check-connection-spec connection-spec database-type + (host db user password &optional port options tty)) + (destructuring-bind (host db user password &optional port options tty) + connection-spec + (declare (ignore password options tty)) + (concatenate 'string host (if port ":") (if port port) "/" db "/" user))) + +(defmethod database-connect + (connection-spec (database-type (eql :postgresql-socket))) + (check-connection-spec connection-spec database-type + (host db user password &optional port options tty)) + (destructuring-bind (host db user password &optional + (port +postgresql-server-default-port+) + (options "") (tty "")) + connection-spec + (handler-case + (handler-bind ((postgresql-warning + (lambda (c) + (warn 'clsql-simple-warning + :format-control "~A" + :format-arguments + (list (princ-to-string c)))))) + (open-postgresql-connection :host host :port port + :options options :tty tty + :database db :user user + :password password)) + (:no-error (connection) + ;; Success, make instance + (make-instance 'postgresql-socket-database + :name (database-name-from-spec connection-spec + database-type) + :connection connection)) + (postgresql-error (c) + ;; Connect failed + (error 'clsql-connect-error + :database-type database-type + :connection-spec connection-spec + :errno (type-of c) + :error (postgresql-condition-message c)))))) + +(defmethod database-disconnect ((database postgresql-socket-database)) + (close-postgresql-connection (database-connection database)) + t) + +(defmethod database-query (expression (database postgresql-socket-database)) + (let ((connection (database-connection database))) + (with-postgresql-handlers (database expression) + (start-query-execution connection expression) + (multiple-value-bind (status cursor) + (wait-for-query-results connection) + (unless (eq status :cursor) + (close-postgresql-connection connection) + (error 'clsql-sql-error + :database database + :expression expression + :errno 'missing-result + :error "Didn't receive result cursor for query.")) + (loop for row = (read-cursor-row cursor) + while row + collect row + finally + (unless (null (wait-for-query-results connection)) + (close-postgresql-connection connection) + (error 'clsql-sql-error + :database database + :expression expression + :errno 'multiple-results + :error "Received multiple results for query."))))))) + +(defmethod database-execute-command + (expression (database postgresql-socket-database)) + (let ((connection (database-connection database))) + (with-postgresql-handlers (database expression) + (start-query-execution connection expression) + (multiple-value-bind (status result) + (wait-for-query-results connection) + (when (eq status :cursor) + (loop + (multiple-value-bind (row stuff) + (skip-cursor-row result) + (unless row + (setq status :completed result stuff) + (return))))) + (cond + ((null status) + t) + ((eq status :completed) + (unless (null (wait-for-query-results connection)) + (close-postgresql-connection connection) + (error 'clsql-sql-error + :database database + :expression expression + :errno 'multiple-results + :error "Received multiple results for command.")) + result) + (t + (close-postgresql-connection connection) + (error 'clsql-sql-error + :database database + :expression expression + :errno 'missing-result + :error "Didn't receive completion for command."))))))) + +(defmethod database-query-result-set + (expression (database postgresql-socket-database) &optional full-set) + (declare (ignore full-set)) + (let ((connection (database-connection database))) + (with-postgresql-handlers (database expression) + (start-query-execution connection expression) + (multiple-value-bind (status cursor) + (wait-for-query-results connection) + (unless (eq status :cursor) + (close-postgresql-connection connection) + (error 'clsql-sql-error + :database database + :expression expression + :errno 'missing-result + :error "Didn't receive result cursor for query.")) + (values (cons nil cursor) + (length (postgresql-cursor-fields cursor))))))) + +(defmethod database-dump-result-set + (result-set (database postgresql-socket-database)) + (if (car result-set) + t + (with-postgresql-handlers (database) + (loop while (skip-cursor-row (cdr result-set)) + finally (setf (car result-set) t))))) + +(defmethod database-store-next-row + (result-set (database postgresql-socket-database) list) + (let ((cursor (cdr result-set))) + (with-postgresql-handlers (database) + (if (copy-cursor-row cursor list) + t + (prog1 nil + (setf (car result-set) t) + (wait-for-query-results (database-connection database))))))) diff --git a/interfaces/postgresql-socket/postgresql-socket-uffi.cl b/interfaces/postgresql-socket/postgresql-socket-uffi.cl new file mode 100644 index 0000000..ff39d18 --- /dev/null +++ b/interfaces/postgresql-socket/postgresql-socket-uffi.cl @@ -0,0 +1,676 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: postgresql-socket.cl +;;;; Purpose: Low-level PostgreSQL interface using sockets +;;;; Programmers: Kevin M. Rosenberg based on +;;;; Original code by Pierre R. Mai +;;;; +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: postgresql-socket-uffi.cl,v 1.1 2002/03/23 14:04:54 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. +;;;; ************************************************************************* + + +;;;; Changes by Kevin Rosenberg +;;;; - Added socket open functions for Allegro and Lispworks +;;;; - Changed CMUCL FFI to UFFI +;;;; - Added necessary (force-output) for socket streams on +;;;; Allegro and Lispworks + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :postgresql-socket) + + +;;; Message I/O stuff + +(defmacro define-message-constants (description &rest clauses) + (assert (evenp (length clauses))) + (loop with seen-characters = nil + for (name char) on clauses by #'cddr + for char-code = (char-code char) + for doc-string = (format nil "~A (~:C): ~A" description char name) + if (member char seen-characters) + do (error "Duplicate message type ~@C for group ~A" char description) + else + collect + `(defconstant ,name ,char-code ,doc-string) + into result-clauses + and do (push char seen-characters) + finally + (return `(progn ,@result-clauses)))) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(define-message-constants "Backend Message Constants" + +ascii-row-message+ #\D + +authentication-message+ #\R + +backend-key-message+ #\K + +binary-row-message+ #\B + +completed-response-message+ #\C + +copy-in-response-message+ #\G + +copy-out-response-message+ #\H + +cursor-response-message+ #\P + +empty-query-response-message+ #\I + +error-response-message+ #\E + +function-response-message+ #\V + +notice-response-message+ #\N + +notification-response-message+ #\A + +ready-for-query-message+ #\Z + +row-description-message+ #\T)) + +(defgeneric send-socket-value (type socket value)) + +(defmethod send-socket-value ((type (eql 'int32)) socket (value integer)) + (write-byte (ldb (byte 8 24) value) socket) + (write-byte (ldb (byte 8 16) value) socket) + (write-byte (ldb (byte 8 8) value) socket) + (write-byte (ldb (byte 8 0) value) socket)) + +(defmethod send-socket-value ((type (eql 'int16)) socket (value integer)) + (write-byte (ldb (byte 8 8) value) socket) + (write-byte (ldb (byte 8 0) value) socket)) + +(defmethod send-socket-value ((type (eql 'int8)) socket (value integer)) + (write-byte (ldb (byte 8 0) value) socket)) + +(defmethod send-socket-value ((type (eql 'string)) socket (value string)) + (loop for char across value + for code = (char-code char) + do (write-byte code socket) + finally (write-byte 0 socket))) + +(defmethod send-socket-value ((type (eql 'limstring)) socket (value string)) + (loop for char across value + for code = (char-code char) + do (write-byte code socket))) + +(defmethod send-socket-value ((type (eql 'byte)) socket (value integer)) + (write-byte value socket)) + +(defmethod send-socket-value ((type (eql 'byte)) socket (value character)) + (write-byte (char-code value) socket)) + +(defmethod send-socket-value ((type (eql 'byte)) socket value) + (write-sequence value socket)) + +(defgeneric read-socket-value (type socket)) + +(defmethod read-socket-value ((type (eql 'int32)) socket) + (let ((result 0)) + (setf (ldb (byte 8 24) result) (read-byte socket)) + (setf (ldb (byte 8 16) result) (read-byte socket)) + (setf (ldb (byte 8 8) result) (read-byte socket)) + (setf (ldb (byte 8 0) result) (read-byte socket)) + result)) + +(defmethod read-socket-value ((type (eql 'int16)) socket) + (let ((result 0)) + (setf (ldb (byte 8 8) result) (read-byte socket)) + (setf (ldb (byte 8 0) result) (read-byte socket)) + result)) + +(defmethod read-socket-value ((type (eql 'int8)) socket) + (read-byte socket)) + +(defmethod read-socket-value ((type (eql 'string)) socket) + (with-output-to-string (out) + (loop for code = (read-byte socket) + until (zerop code) + do (write-char (code-char code) out)))) + +(defgeneric skip-socket-value (type socket)) + +(defmethod skip-socket-value ((type (eql 'int32)) socket) + (dotimes (i 4) (read-byte socket))) + +(defmethod skip-socket-value ((type (eql 'int16)) socket) + (dotimes (i 2) (read-byte socket))) + +(defmethod skip-socket-value ((type (eql 'int8)) socket) + (read-byte socket)) + +(defmethod skip-socket-value ((type (eql 'string)) socket) + (loop until (zerop (read-byte socket)))) + +(defmacro define-message-sender (name (&rest args) &rest clauses) + (loop with socket-var = (gensym) + for (type value) in clauses + collect + `(send-socket-value ',type ,socket-var ,value) + into body + finally + (return + `(defun ,name (,socket-var ,@args) + ,@body)))) + +(defun pad-limstring (string limit) + (let ((result (make-string limit :initial-element #\NULL))) + (loop for char across string + for index from 0 below limit + do (setf (char result index) char)) + result)) + +(define-message-sender send-startup-message + (database user &optional (command-line "") (backend-tty "")) + (int32 296) ; Length + (int32 #x00020000) ; Version 2.0 + (limstring (pad-limstring database 64)) + (limstring (pad-limstring user 32)) + (limstring (pad-limstring command-line 64)) + (limstring (pad-limstring "" 64)) ; Unused + (limstring (pad-limstring backend-tty 64))) + +(define-message-sender send-terminate-message () + (byte #\X)) + +(define-message-sender send-unencrypted-password-message (password) + (int32 (+ 5 (length password))) + (string password)) + +(define-message-sender send-query-message (query) + (byte #\Q) + (string query)) + +(define-message-sender send-encrypted-password-message (crypted-password) + (int32 (+ 5 (length crypted-password))) + (string crypted-password)) + +(define-message-sender send-cancel-request (pid key) + (int32 16) ; Length + (int32 80877102) ; Magic + (int32 pid) + (int32 key)) + +;;; Support for encrypted password transmission + +(defconstant +crypt-library+ "/usr/lib/libcrypt.so" + "Name of the shared library to load in order to access the crypt +function named by `*crypt-function-name*'.") + +(defvar *crypt-library-loaded* nil) + +(defun crypt-password (password salt) + "Encrypt a password for transmission to a PostgreSQL server." + (unless *crypt-library-loaded* + (uffi:load-foreign-library +crypt-library+ :supporting-libaries '("c")) + (eval (uffi:def-function "crypt" + ((key :cstring) + (salt :cstring)) + :returning :cstring)) + (setq *crypt-library-loaded* t)) + (uffi:with-cstring (password-cstring password) + (uffi:with-cstring (salt-cstring salt) + (uffi:convert-from-cstring (crypt password-cstring salt-cstring))))) +;;; Condition hierarchy + +(define-condition postgresql-condition (condition) + ((connection :initarg :connection :reader postgresql-condition-connection) + (message :initarg :message :reader postgresql-condition-message)) + (:report + (lambda (c stream) + (format stream "~@<~A occurred on connection ~A. ~:@_Reason: ~A~:@>" + (type-of c) + (postgresql-condition-connection c) + (postgresql-condition-message c))))) + +(define-condition postgresql-error (error postgresql-condition) + ()) + +(define-condition postgresql-fatal-error (postgresql-error) + ()) + +(define-condition postgresql-login-error (postgresql-fatal-error) + ()) + +(define-condition postgresql-warning (warning postgresql-condition) + ()) + +(define-condition postgresql-notification (postgresql-condition) + () + (:report + (lambda (c stream) + (format stream "~@" + (postgresql-condition-connection c) + (postgresql-condition-message c))))) + +;;; Structures + +(defstruct postgresql-connection + host + port + database + user + password + options + tty + socket + pid + key) + +(defstruct postgresql-cursor + connection + name + fields) + +;;; Socket stuff + +(defconstant +postgresql-server-default-port+ 5432 + "Default port of PostgreSQL server.") + +(defvar *postgresql-server-socket-timeout* 60 + "Timeout in seconds for reads from the PostgreSQL server.") + + +#+cmu +(defun open-postgresql-socket (host port) + (etypecase host + (pathname + ;; Directory to unix-domain socket + (ext:connect-to-unix-socket + (namestring + (make-pathname :name ".s.PGSQL" :type (princ-to-string port) + :defaults host)))) + (string + (ext:connect-to-inet-socket host port)))) + +#+cmu +(defun open-postgresql-socket-stream (host port) + (system:make-fd-stream + (open-postgresql-socket host port) + :input t :output t :element-type '(unsigned-byte 8) + :buffering :none + :timeout *postgresql-server-socket-timeout*)) + +#+allegro +(defun open-postgresql-socket-stream (host port) + (etypecase host + (pathname + (let ((path (namestring + (make-pathname :name ".s.PGSQL" :type (princ-to-string port) + :defaults host)))) + (socket:make-socket :type :stream :address-family :file + :connect :active + :remote-filename path :local-filename path))) + (string + (socket:with-pending-connect + (mp:with-timeout (*postgresql-server-socket-timeout* (error "connect failed")) + (socket:make-socket :type :stream :address-family :internet + :remote-port port :remote-host host + :connect :active :nodelay t)))) + )) + +#+lispworks +(defun open-postgresql-socket-stream (host port) + (etypecase host + (pathname + (error "File sockets not supported on Lispworks.")) + (string + (comm:open-tcp-stream host port :direction :io :element-type '(unsigned-byte 8) + :read-timeout *postgresql-server-socket-timeout*)) + )) + +;;; Interface Functions + +(defun open-postgresql-connection (&key (host (cmucl-compat:required-argument)) + (port +postgresql-server-default-port+) + (database (cmucl-compat:required-argument)) + (user (cmucl-compat:required-argument)) + options tty password) + "Open a connection to a PostgreSQL server with the given parameters. +Note that host, database and user arguments must be supplied. + +If host is a pathname, it is assumed to name a directory containing +the local unix-domain sockets of the server, with port selecting which +of those sockets to open. If host is a string, it is assumed to be +the name of the host running the PostgreSQL server. In that case a +TCP connection to the given port on that host is opened in order to +communicate with the server. In either case the port argument +defaults to `+postgresql-server-default-port+'. + +Password is the clear-text password to be passed in the authentication +phase to the server. Depending on the server set-up, it is either +passed in the clear, or encrypted via crypt and a server-supplied +salt. In that case the alien function specified by `*crypt-library*' +and `*crypt-function-name*' is used for encryption. + +Note that all the arguments (including the clear-text password +argument) are stored in the `postgresql-connection' structure, in +order to facilitate automatic reconnection in case of communication +troubles." + (reopen-postgresql-connection + (make-postgresql-connection :host host :port port + :options (or options "") :tty (or tty "") + :database database :user user + :password (or password "")))) + +(defun reopen-postgresql-connection (connection) + "Reopen the given PostgreSQL connection. Closes any existing +connection, if it is still open." + (when (postgresql-connection-open-p connection) + (close-postgresql-connection connection)) + (let ((socket (open-postgresql-socket-stream + (postgresql-connection-host connection) + (postgresql-connection-port connection)))) + (unwind-protect + (progn + (setf (postgresql-connection-socket connection) socket) + (send-startup-message socket + (postgresql-connection-database connection) + (postgresql-connection-user connection) + (postgresql-connection-options connection) + (postgresql-connection-tty connection)) + (force-output socket) + (loop + (case (read-socket-value 'int8 socket) + (#.+authentication-message+ + (case (read-socket-value 'int32 socket) + (0 (return)) + ((1 2) + (error 'postgresql-login-error + :connection connection + :message + "Postmaster expects unsupported Kerberos authentication.")) + (3 + (send-unencrypted-password-message + socket + (postgresql-connection-password connection))) + (4 + (let ((salt (make-string 2))) + (read-sequence salt socket) + (send-encrypted-password-message + socket + (crypt-password + (postgresql-connection-password connection) salt)))) + (t + (error 'postgresql-login-error + :connection connection + :message + "Postmaster expects unknown authentication method.")))) + (#.+error-response-message+ + (let ((message (read-socket-value 'string socket))) + (error 'postgresql-login-error + :connection connection :message message))) + (t + (error 'postgresql-login-error + :connection connection + :message + "Received garbled message from Postmaster")))) + ;; Start backend communication + (force-output socket) + (loop + (case (read-socket-value 'int8 socket) + (#.+backend-key-message+ + (setf (postgresql-connection-pid connection) + (read-socket-value 'int32 socket) + (postgresql-connection-key connection) + (read-socket-value 'int32 socket))) + (#.+ready-for-query-message+ + (setq socket nil) + (return connection)) + (#.+error-response-message+ + (let ((message (read-socket-value 'string socket))) + (error 'postgresql-login-error + :connection connection + :message message))) + (#.+notice-response-message+ + (let ((message (read-socket-value 'string socket))) + (warn 'postgresql-warning :connection connection + :message message))) + (t + (error 'postgresql-login-error + :connection connection + :message + "Received garbled message from Postmaster"))))) + (when socket + (close socket))))) + +(defun close-postgresql-connection (connection &optional abort) + (unless abort + (ignore-errors + (send-terminate-message (postgresql-connection-socket connection)))) + (close (postgresql-connection-socket connection))) + +(defun postgresql-connection-open-p (connection) + (let ((socket (postgresql-connection-socket connection))) + (and socket (streamp socket) (open-stream-p socket)))) + +(defun ensure-open-postgresql-connection (connection) + (unless (postgresql-connection-open-p connection) + (reopen-postgresql-connection connection))) + +(defun process-async-messages (connection) + (assert (postgresql-connection-open-p connection)) + ;; Process any asnychronous messages + (loop with socket = (postgresql-connection-socket connection) + while (listen socket) + do + (case (read-socket-value 'int8 socket) + (#.+notice-response-message+ + (let ((message (read-socket-value 'string socket))) + (warn 'postgresql-warning :connection connection + :message message))) + (#.+notification-response-message+ + (let ((pid (read-socket-value 'int32 socket)) + (message (read-socket-value 'string socket))) + (when (= pid (postgresql-connection-pid connection)) + (signal 'postgresql-notification :connection connection + :message message)))) + (t + (close-postgresql-connection connection) + (error 'postgresql-fatal-error :connection connection + :message "Received garbled message from backend"))))) + +(defun start-query-execution (connection query) + (ensure-open-postgresql-connection connection) + (process-async-messages connection) + (send-query-message (postgresql-connection-socket connection) query) + (force-output (postgresql-connection-socket connection))) + +(defun wait-for-query-results (connection) + (assert (postgresql-connection-open-p connection)) + (let ((socket (postgresql-connection-socket connection)) + (cursor-name nil) + (error nil)) + (loop + (case (read-socket-value 'int8 socket) + (#.+completed-response-message+ + (return (values :completed (read-socket-value 'string socket)))) + (#.+cursor-response-message+ + (setq cursor-name (read-socket-value 'string socket))) + (#.+row-description-message+ + (let* ((count (read-socket-value 'int16 socket)) + (fields + (loop repeat count + collect + (list + (read-socket-value 'string socket) + (read-socket-value 'int32 socket) + (read-socket-value 'int16 socket) + (read-socket-value 'int32 socket))))) + (return + (values :cursor + (make-postgresql-cursor :connection connection + :name cursor-name + :fields fields))))) + (#.+copy-in-response-message+ + (return :copy-in)) + (#.+copy-out-response-message+ + (return :copy-out)) + (#.+ready-for-query-message+ + (when error + (error error)) + (return nil)) + (#.+error-response-message+ + (let ((message (read-socket-value 'string socket))) + (setq error + (make-condition 'postgresql-error + :connection connection :message message)))) + (#.+notice-response-message+ + (let ((message (read-socket-value 'string socket))) + (warn 'postgresql-warning + :connection connection :message message))) + (#.+notification-response-message+ + (let ((pid (read-socket-value 'int32 socket)) + (message (read-socket-value 'string socket))) + (when (= pid (postgresql-connection-pid connection)) + (signal 'postgresql-notification :connection connection + :message message)))) + (t + (close-postgresql-connection connection) + (error 'postgresql-fatal-error :connection connection + :message "Received garbled message from backend")))))) + +(defun read-null-bit-vector (socket count) + (let ((result (make-array count :element-type 'bit))) + (dotimes (offset (ceiling count 8)) + (loop with byte = (read-byte socket) + for index from (* offset 8) below (min count (* (1+ offset) 8)) + for weight downfrom 7 + do (setf (aref result index) (ldb (byte 1 weight) byte)))) + result)) + +(defun read-cursor-row (cursor) + (let* ((connection (postgresql-cursor-connection cursor)) + (socket (postgresql-connection-socket connection)) + (fields (postgresql-cursor-fields cursor))) + (assert (postgresql-connection-open-p connection)) + (loop + (let ((code (read-socket-value 'int8 socket))) + (case code + (#.+ascii-row-message+ + (return + (loop with count = (length fields) + with null-vector = (read-null-bit-vector socket count) + repeat count + for null-bit across null-vector + for null-p = (zerop null-bit) + if null-p + collect nil + else + collect + (let* ((length (read-socket-value 'int32 socket)) + (result (make-string (- length 4)))) + (read-sequence result socket) + result)))) + (#.+binary-row-message+ + (error "NYI")) + (#.+completed-response-message+ + (return (values nil (read-socket-value 'string socket)))) + (#.+error-response-message+ + (let ((message (read-socket-value 'string socket))) + (error 'postgresql-error + :connection connection :message message))) + (#.+notice-response-message+ + (let ((message (read-socket-value 'string socket))) + (warn 'postgresql-warning + :connection connection :message message))) + (#.+notification-response-message+ + (let ((pid (read-socket-value 'int32 socket)) + (message (read-socket-value 'string socket))) + (when (= pid (postgresql-connection-pid connection)) + (signal 'postgresql-notification :connection connection + :message message)))) + (t + (close-postgresql-connection connection) + (error 'postgresql-fatal-error :connection connection + :message "Received garbled message from backend"))))))) + +(defun copy-cursor-row (cursor sequence) + (let* ((connection (postgresql-cursor-connection cursor)) + (socket (postgresql-connection-socket connection)) + (fields (postgresql-cursor-fields cursor))) + (assert (= (length fields) (length sequence))) + (loop + (let ((code (read-socket-value 'int8 socket))) + (case code + (#.+ascii-row-message+ + (return + (map-into + sequence + #'(lambda (null-bit) + (if (zerop null-bit) + nil + (let* ((length (read-socket-value 'int32 socket)) + (result (make-string (- length 4)))) + (read-sequence result socket) + result))) + (read-null-bit-vector socket (length sequence))))) + (#.+binary-row-message+ + (error "NYI")) + (#.+completed-response-message+ + (return (values nil (read-socket-value 'string socket)))) + (#.+error-response-message+ + (let ((message (read-socket-value 'string socket))) + (error 'postgresql-error + :connection connection :message message))) + (#.+notice-response-message+ + (let ((message (read-socket-value 'string socket))) + (warn 'postgresql-warning + :connection connection :message message))) + (#.+notification-response-message+ + (let ((pid (read-socket-value 'int32 socket)) + (message (read-socket-value 'string socket))) + (when (= pid (postgresql-connection-pid connection)) + (signal 'postgresql-notification :connection connection + :message message)))) + (t + (close-postgresql-connection connection) + (error 'postgresql-fatal-error :connection connection + :message "Received garbled message from backend"))))))) + +(defun skip-cursor-row (cursor) + (let* ((connection (postgresql-cursor-connection cursor)) + (socket (postgresql-connection-socket connection)) + (fields (postgresql-cursor-fields cursor))) + (loop + (let ((code (read-socket-value 'int8 socket))) + (case code + (#.+ascii-row-message+ + (loop for null-bit across + (read-null-bit-vector socket (length fields)) + do + (unless (zerop null-bit) + (let* ((length (read-socket-value 'int32 socket))) + (loop repeat (- length 4) do (read-byte socket))))) + (return t)) + (#.+binary-row-message+ + (error "NYI")) + (#.+completed-response-message+ + (return (values nil (read-socket-value 'string socket)))) + (#.+error-response-message+ + (let ((message (read-socket-value 'string socket))) + (error 'postgresql-error + :connection connection :message message))) + (#.+notice-response-message+ + (let ((message (read-socket-value 'string socket))) + (warn 'postgresql-warning + :connection connection :message message))) + (#.+notification-response-message+ + (let ((pid (read-socket-value 'int32 socket)) + (message (read-socket-value 'string socket))) + (when (= pid (postgresql-connection-pid connection)) + (signal 'postgresql-notification :connection connection + :message message)))) + (t + (close-postgresql-connection connection) + (error 'postgresql-fatal-error :connection connection + :message "Received garbled message from backend"))))))) + +(defun run-query (connection query) + (start-query-execution connection query) + (multiple-value-bind (status cursor) + (wait-for-query-results connection) + (assert (eq status :cursor)) + (loop for row = (read-cursor-row cursor) + while row + collect row + finally + (wait-for-query-results connection)))) diff --git a/interfaces/postgresql/.cvsignore b/interfaces/postgresql/.cvsignore new file mode 100755 index 0000000..ca8d09f --- /dev/null +++ b/interfaces/postgresql/.cvsignore @@ -0,0 +1 @@ +.bin diff --git a/interfaces/postgresql/postgresql-loader.cl b/interfaces/postgresql/postgresql-loader.cl new file mode 100644 index 0000000..4db5fd4 --- /dev/null +++ b/interfaces/postgresql/postgresql-loader.cl @@ -0,0 +1,48 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: postgresql-loader.sql +;;;; Purpose: PostgreSQL library loader using UFFI +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: postgresql-loader.cl,v 1.1 2002/03/23 14:04:53 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 :postgresql) + +(defvar *postgresql-library-filename* + (cond + ((probe-file "/opt/postgresql/lib/libpq.so") + "/opt/postgresql/lib/libpq.so") + ((probe-file "/usr/local/lib/libpq.so") + "/usr/local/lib/libpq.so") + ((probe-file "/usr/lib/libpq.so") + "/usr/lib/libpq.so") + #+(or win32 mswindows) + ((probe-file "c:/postgresql/lib/libpq.dll") + "c:/postgresql/lib/libpq.dll") + (t + (warn "Can't find PostgresQL client library to load."))) + "Location where the PostgresSQL client library is to be found.") + +(defvar *postgresql-supporting-libraries* '("crypt" "c") + "Used only by CMU. List of library flags needed to be passed to ld to +load the PostgresSQL client library succesfully. If this differs at your site, +set to the right path before compiling or loading the system.") + +(defmethod database-type-load-foreign ((database-type (eql :postgresql))) + (uffi:load-foreign-library *postgresql-library-filename* + :module "postgresql" + :supporting-libraries + *postgresql-supporting-libraries*)) + +(database-type-load-foreign :postgresql) diff --git a/interfaces/postgresql/postgresql-package.cl b/interfaces/postgresql/postgresql-package.cl new file mode 100644 index 0000000..48d8d5e --- /dev/null +++ b/interfaces/postgresql/postgresql-package.cl @@ -0,0 +1,67 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: postgresql-package.cl +;;;; Purpose: Package definition for low-level PostgreSQL interface +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: postgresql-package.cl,v 1.1 2002/03/23 14:04:53 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 :postgresql + (:nicknames :pgsql) + (:use :common-lisp) + (:export + #:pgsql-oid + #:pgsql-conn-status-type + #:pgsql-conn-status-type#connection-ok + #:pgsql-conn-status-type#connection-bad + #:pgsql-exec-status-type + #:pgsql-exec-status-type#empty-query + #:pgsql-exec-status-type#command-ok + #:pgsql-exec-status-type#tuples-ok + #:pgsql-exec-status-type#copy-out + #:pgsql-exec-status-type#copy-in + #:pgsql-exec-status-type#bad-response + #:pgsql-exec-status-type#nonfatal-error + #:pgsql-exec-status-type#fatal-error + #:pgsql-conn + #:pgsql-result + + ;; Functions + #:PQsetdbLogin + #:PQlogin + #:PQfinish + #:PQstatus + #:PQerrorMessage + #:PQexec + #:PQresultStatus + #:PQresultErrorMessage + #:PQntuples + #:PQnfields + #:PQfname + #:PQfnumber + #:PQftype + #:PQfsize + #:PQcmdStatus + #:PQoidStatus + #:PQcmdTuples + #:PQgetvalue + #:PQgetlength + #:PQgetisnull + #:PQclear + ) + (:documentation "This is the low-level interface to PostgreSQL.")) + + diff --git a/interfaces/postgresql/postgresql-sql.cl b/interfaces/postgresql/postgresql-sql.cl new file mode 100644 index 0000000..cb83a34 --- /dev/null +++ b/interfaces/postgresql/postgresql-sql.cl @@ -0,0 +1,233 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: postgresql-sql.sql +;;;; Purpose: High-level PostgreSQL interface using UFFI +;;;; Programmers: Kevin M. Rosenberg based on +;;;; Original code by Pierre R. Mai +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: postgresql-sql.cl,v 1.1 2002/03/23 14:04:53 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) + +(defpackage :clsql-postgresql + (:use :common-lisp :clsql-sys :postgresql) + (:export #:postgresql-database) + (:documentation "This is the CLSQL interface to PostgreSQL.")) + +(in-package :clsql-postgresql) + + +(defun tidy-error-message (message) + (unless (stringp message) + (setq message (uffi:convert-from-foreign-string message))) + (let ((message (string-right-trim '(#\Return #\Newline) message))) + (cond + ((< (length message) (length "ERROR:")) + message) + ((string= message "ERROR:" :end1 6) + (string-left-trim '(#\Space) (subseq message 6))) + (t + message)))) + +(defmethod database-initialize-database-type ((database-type + (eql :postgresql))) + t) + +(uffi:def-type pgsql-conn-def pgsql-conn) +(uffi:def-type pgsql-result-def pgsql-result) + + +(defclass postgresql-database (database) + ((conn-ptr :accessor database-conn-ptr :initarg :conn-ptr + :type pgsql-conn-def))) + +(defmethod database-name-from-spec (connection-spec (database-type + (eql :postgresql))) + (check-connection-spec connection-spec database-type + (host db user password &optional port options tty)) + (destructuring-bind (host db user password &optional port options tty) + connection-spec + (declare (ignore password options tty)) + (concatenate 'string host (if port ":") (if port port) "/" db "/" user))) + + +(defmethod database-connect (connection-spec (database-type (eql :postgresql))) + (check-connection-spec connection-spec database-type + (host db user password &optional port options tty)) + (destructuring-bind (host db user password &optional port options tty) + connection-spec + (uffi:with-cstring (host-native host) + (uffi:with-cstring (user-native user) + (uffi:with-cstring (password-native password) + (uffi:with-cstring (db-native db) + (uffi:with-cstring (port-native port) + (uffi:with-cstring (options-native options) + (uffi:with-cstring (tty-native tty) + (let ((connection (PQsetdbLogin host-native port-native + options-native tty-native + db-native user-native + password-native))) + (declare (type pgsql-conn-def connection)) + (when (not (eq (PQstatus connection) + pgsql-conn-status-type#connection-ok)) + (error 'clsql-connect-error + :database-type database-type + :connection-spec connection-spec + :errno (PQstatus connection) + :error (tidy-error-message + (PQerrorMessage connection)))) + (make-instance 'postgresql-database + :name (database-name-from-spec connection-spec + database-type) + :conn-ptr connection))))))))))) + + +(defmethod database-disconnect ((database postgresql-database)) + (PQfinish (database-conn-ptr database)) + (setf (database-conn-ptr database) nil) + t) + +(defmethod database-query (query-expression (database postgresql-database)) + (let ((conn-ptr (database-conn-ptr database))) + (declare (type pgsql-conn-def conn-ptr)) + (uffi:with-cstring (query-native query-expression) + (let ((result (PQexec conn-ptr query-native))) + (when (uffi:null-pointer-p result) + (error 'clsql-sql-error + :database database + :expression query-expression + :errno nil + :error (tidy-error-message (PQerrorMessage conn-ptr)))) + (unwind-protect + (case (PQresultStatus result) + (#.pgsql-exec-status-type#empty-query + nil) + (#.pgsql-exec-status-type#tuples-ok + (loop for tuple-index from 0 below (PQntuples result) + collect + (loop for i from 0 below (PQnfields result) + collect + (if (zerop (PQgetisnull result tuple-index i)) + (uffi:convert-from-cstring + (PQgetvalue result tuple-index i)) + nil)))) + (t + (error 'clsql-sql-error + :database database + :expression query-expression + :errno (PQresultStatus result) + :error (tidy-error-message + (PQresultErrorMessage result))))) + (PQclear result)))))) + +(defmethod database-execute-command (sql-expression + (database postgresql-database)) + (let ((conn-ptr (database-conn-ptr database))) + (declare (type pgsql-conn-def conn-ptr)) + (uffi:with-cstring (sql-native sql-expression) + (let ((result (PQexec conn-ptr sql-native))) + (when (uffi:null-pointer-p result) + (error 'clsql-sql-error + :database database + :expression sql-expression + :errno nil + :error (tidy-error-message (PQerrorMessage conn-ptr)))) + (unwind-protect + (case (PQresultStatus result) + (#.pgsql-exec-status-type#command-ok + t) + ((#.pgsql-exec-status-type#empty-query + #.pgsql-exec-status-type#tuples-ok) + (warn "Strange result...") + t) + (t + (error 'clsql-sql-error + :database database + :expression sql-expression + :errno (PQresultStatus result) + :error (tidy-error-message + (PQresultErrorMessage result))))) + (PQclear result)))))) + +(defstruct postgresql-result-set + (res-ptr (uffi:make-null-pointer 'pgsql-result) + :type pgsql-result-def) + (num-tuples 0) + (num-fields 0) + (tuple-index 0)) + +(defmethod database-query-result-set (query-expression + (database postgresql-database) + &optional full-set) + (let ((conn-ptr (database-conn-ptr database))) + (declare (type pgsql-conn-def conn-ptr)) + (uffi:with-cstring (query-native query-expression) + (let ((result (PQexec conn-ptr query-native))) + (when (uffi:null-pointer-p result) + (error 'clsql-sql-error + :database database + :expression query-expression + :errno nil + :error (tidy-error-message (PQerrorMessage conn-ptr)))) + (case (PQresultStatus result) + ((#.pgsql-exec-status-type#empty-query + #.pgsql-exec-status-type#tuples-ok) + (if full-set + (values (make-postgresql-result-set + :res-ptr result + :num-fields (PQnfields result) + :num-tuples (PQntuples result)) + (PQnfields result) + (PQntuples result)) + (values (make-postgresql-result-set + :res-ptr result + :num-fields (PQnfields result) + :num-tuples (PQntuples result)) + (PQnfields result)))) + (t + (unwind-protect + (error 'clsql-sql-error + :database database + :expression query-expression + :errno (PQresultStatus result) + :error (tidy-error-message + (PQresultErrorMessage result))) + (PQclear result)))))))) + +(defmethod database-dump-result-set (result-set (database postgresql-database)) + (let ((res-ptr (postgresql-result-set-res-ptr result-set))) + (declare (type pgsql-result-def res-ptr)) + (PQclear res-ptr) + t)) + +(defmethod database-store-next-row (result-set (database postgresql-database) + list) + (let ((result (postgresql-result-set-res-ptr result-set))) + (declare (type pgsql-result-def result)) + (if (>= (postgresql-result-set-tuple-index result-set) + (postgresql-result-set-num-tuples result-set)) + nil + (loop with tuple-index = (postgresql-result-set-tuple-index result-set) + for i from 0 below (postgresql-result-set-num-fields result-set) + for rest on list + do + (setf (car rest) + (if (zerop (PQgetisnull result tuple-index i)) + (uffi:convert-from-cstring + (PQgetvalue result tuple-index i)) + nil)) + finally + (incf (postgresql-result-set-tuple-index result-set)) + (return list))))) diff --git a/interfaces/postgresql/postgresql-uffi.cl b/interfaces/postgresql/postgresql-uffi.cl new file mode 100644 index 0000000..af3a1b0 --- /dev/null +++ b/interfaces/postgresql/postgresql-uffi.cl @@ -0,0 +1,190 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: postgresql.cl +;;;; Purpose: Low-level PostgreSQL interface using UFFI +;;;; Programmers: Kevin M. Rosenberg based on +;;;; Original code by Pierre R. Mai +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: postgresql-uffi.cl,v 1.1 2002/03/23 14:04:53 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 :postgresql) + + +;;;; This file implements as little of the FFI bindings to the +;;;; PostgreSQL client libraries as we could get away with. +;;;; Especially all the PostgreSQL-specific goodies aren't there, and +;;;; we just use void pointers where we can get away with it, which +;;;; thanks to the design of the PostgreSQL client libraries is pretty +;;;; much everywhere, in contrast to the MySQL client libraries for +;;;; example. + +;;;; Type definitions + +;;; Basic Types + +(uffi:def-foreign-type pgsql-oid :unsigned-int) + +(uffi:def-enum pgsql-conn-status-type + (:connection-ok + :connection-bad)) + +(uffi:def-enum pgsql-exec-status-type + (:empty-query + :command-ok + :tuples-ok + :copy-out + :copy-in + :bad-response + :nonfatal-error + :fatal-error)) + +(uffi:def-foreign-type pgsql-conn :pointer-void) +(uffi:def-foreign-type pgsql-result :pointer-void) + +;;(declaim (inline PQsetdbLogin)) ;; causes compile error in LW 4.2.0 +(uffi:def-function ("PQsetdbLogin" PQsetdbLogin) + ((pghost :cstring) + (pgport :cstring) + (pgoptions :cstring) + (pgtty :cstring) + (dbName :cstring) + (login :cstring) + (pwd :cstring)) + :returning pgsql-conn) + +(declaim (inline PQfinish)) +(uffi:def-function ("PQfinish" PQfinish) + ((conn pgsql-conn)) + :module "postgresql" + :returning :void) + +(declaim (inline PQstatus)) +(uffi:def-function ("PQstatus" PQstatus) + ((conn pgsql-conn)) + :module "postgresql" + :returning pgsql-conn-status-type) + +(declaim (inline PQerrorMessage)) +(uffi:def-function ("PQerrorMessage" PQerrorMessage) + ((conn pgsql-conn)) + :module "postgresql" + :returning :cstring) + +(declaim (inline PQexec)) +(uffi:def-function ("PQexec" PQexec) + ((conn pgsql-conn) + (query :cstring)) + :module "postgresql" + :returning pgsql-result) + +(declaim (inline PQresultStatus)) +(uffi:def-function ("PQresultStatus" PQresultStatus) + ((res pgsql-result)) + :module "postgresql" + :returning pgsql-exec-status-type) + +(declaim (inline PQresultErrorMessage)) +(uffi:def-function ("PQresultErrorMessage" PQresultErrorMessage) + ((res pgsql-result)) + :module "postgresql" + :returning :cstring) + +(declaim (inline PQntuples)) +(uffi:def-function ("PQntuples" PQntuples) + ((res pgsql-result)) + :module "postgresql" + :returning :int) + +(declaim (inline PQnfields)) +(uffi:def-function ("PQnfields" PQnfields) + ((res pgsql-result)) + :module "postgresql" + :returning :int) + +(declaim (inline PQfname)) +(uffi:def-function ("PQfname" PQfname) + ((res pgsql-result) + (field-num :int)) + :module "postgresql" + :returning :cstring) + +(declaim (inline PQfnumber)) +(uffi:def-function ("PQfnumber" PQfnumber) + ((res pgsql-result) + (field-name :cstring)) + :module "postgresql" + :returning :int) + +(declaim (inline PQftype)) +(uffi:def-function ("PQftype" PQftype) + ((res pgsql-result) + (field-num :int)) + :module "postgresql" + :returning pgsql-oid) + +(declaim (inline PQfsize)) +(uffi:def-function ("PQfsize" PQfsize) + ((res pgsql-result) + (field-num :int)) + :module "postgresql" + :returning :short) + +(declaim (inline PQcmdStatus)) +(uffi:def-function ("PQcmdStatus" PQcmdStatus) + ((res pgsql-result)) + :module "postgresql" + :returning :cstring) + +(declaim (inline PQoidStatus)) +(uffi:def-function ("PQoidStatus" PQoidStatus) + ((res pgsql-result)) + :module "postgresql" + :returning :cstring) + +(declaim (inline PQcmdTuples)) +(uffi:def-function ("PQcmdTuples" PQcmdTuples) + ((res pgsql-result)) + :module "postgresql" + :returning :cstring) + +(declaim (inline PQgetvalue)) +(uffi:def-function ("PQgetvalue" PQgetvalue) + ((res pgsql-result) + (tup-num :int) + (field-num :int)) + :module "postgresql" + :returning :cstring) + +(declaim (inline PQgetlength)) +(uffi:def-function ("PQgetlength" PQgetlength) + ((res pgsql-result) + (tup-num :int) + (field-num :int)) + :module "postgresql" + :returning :int) + +(declaim (inline PQgetisnull)) +(uffi:def-function ("PQgetisnull" PQgetisnull) + ((res pgsql-result) + (tup-num :int) + (field-num :int)) + :module "postgresql" + :returning :int) + +(declaim (inline PQclear)) +(uffi:def-function ("PQclear" PQclear) + ((res pgsql-result)) + :module "postgresql" + :returning :void) diff --git a/set-logical.cl b/set-logical.cl new file mode 100644 index 0000000..cb4224d --- /dev/null +++ b/set-logical.cl @@ -0,0 +1,63 @@ +;;;; -*- 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))) + ("**;bin;*.*.*" ,(merge-pathnames + (make-pathname + :name :wild + :type :wild + :directory + (append '(:relative :wild-inferiors + ".bin" #.+set-logical-compiler-name+))) + base-pathname)) + ("**;*.*.*" ,(merge-pathnames + (make-pathname + :name :wild + :type :wild + :directory '(:relative :wild-inferiors)) + base-pathname)))) + ) diff --git a/sql/.cvsignore b/sql/.cvsignore new file mode 100755 index 0000000..ca8d09f --- /dev/null +++ b/sql/.cvsignore @@ -0,0 +1 @@ +.bin diff --git a/sql/functional.cl b/sql/functional.cl new file mode 100644 index 0000000..d5f72dd --- /dev/null +++ b/sql/functional.cl @@ -0,0 +1,94 @@ +;;;; -*- 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/03/23 14:04:54 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 on exit from the body." + `(let ((,db-var (connect ,connection-spec ,@connect-args))) + (unwind-protect + (let ((,db-var ,db-var)) ,@body) + (disconnect :database ,db-var)))) diff --git a/sql/package.cl b/sql/package.cl new file mode 100644 index 0000000..48c5da9 --- /dev/null +++ b/sql/package.cl @@ -0,0 +1,108 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: package.cl +;;;; Purpose: Package definition for high-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/03/23 14:04:54 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-sys + (:use :common-lisp) + (:export + ;; "Private" exports for use by interface packages + #:check-connection-spec + #:database-type-load-foreign + #: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 + ;; Shared exports for re-export by CLSQL + . + #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 + #:connect + #:disconnect + #:query + #:execute-command + #:map-query + #:do-query + #:insert-records + #:delete-records + #:update-records + #:select + #:with-database)) + (:documentation "This is the INTERNAL SQL-Interface package of CLSQL.")) + +(defpackage #:clsql + (:import-from #:clsql-sys . #1#) + (:export . #1#) + (:documentation "This is the SQL-Interface package of CLSQL.")) +);eval-when + +(defpackage #:clsql-user + (:use #:common-lisp #:clsql) + (:documentation "This is the user package for experimenting with CLSQL.")) diff --git a/sql/sql.cl b/sql/sql.cl new file mode 100644 index 0000000..6969974 --- /dev/null +++ b/sql/sql.cl @@ -0,0 +1,467 @@ +;;;; -*- 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/03/23 14:04:54 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 to use CMUCL-COMPAT library and to fix format strings in +;;;; error messages + +;;;; Simple implementation of SQL along the lines of Harlequin's Common SQL + +;;; 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))))) + +;;; Database Types + +(defvar *loaded-database-types* nil + "Contains a list of database types which have been defined/loaded.") + +(defun reload-database-types () + "Reloads any foreign code for the loaded database types after a dump." + (mapc #'database-type-load-foreign *loaded-database-types*)) + +(defgeneric database-type-load-foreign (database-type) + (:documentation + "The internal generic implementation of reload-database-types.") + (:method :after (database-type) + (pushnew database-type *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))) + +(defgeneric database-initialize-database-type (database-type) + (:documentation + "The internal generic implementation of initialize-database-type.")) + +;;; 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.") + +(defclass database () + ((name :initarg :name :reader database-name)) + (:documentation + "This class is the supertype of all databases handled by CLSQL.")) + +(defmethod print-object ((object database) stream) + (print-unreadable-object (object stream :type t :identity t) + (write-string (if (slot-boundp object 'name) + (database-name object) + "") + stream))) + +(defclass closed-database () + ((name :initarg :name :reader database-name)) + (:documentation + "This class represents all databases after they are closed via +`disconnect'.")) + +(defmethod print-object ((object closed-database) stream) + (print-unreadable-object (object stream :type t :identity t) + (write-string (if (slot-boundp object 'name) + (database-name object) + "") + stream))) + +(defun signal-closed-database-error (database) + (cerror "Ignore this error and return nil." + 'clsql-closed-error + :database database)) + +(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*)) + "Connects to a database of the given database-type, using the type-specific +connection-spec. if-exists is currently ignored." + (let* ((db-name (database-name-from-spec connection-spec database-type)) + (old-db (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))) + +(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.")) + +(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." + (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)) + +(defgeneric database-disconnect (database) + (:method ((database closed-database)) + (signal-closed-database-error database)) + (:documentation "Internal generic implementation of disconnect.")) + +;;; Basic operations on databases + +(defmethod query (query-expression &key (database *default-database*)) + "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)) + +(defgeneric database-query (query-expression database) + (:method (query-expression (database closed-database)) + (declare (ignore query-expression)) + (signal-closed-database-error database)) + (:documentation "Internal generic implementation of query.")) + +(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)) + +(defgeneric database-execute-command (sql-expression database) + (:method (sql-expression (database closed-database)) + (declare (ignore sql-expression)) + (signal-closed-database-error database)) + (:documentation "Internal generic implementation of execute-command.")) + +;;; Mapping and iteration +(defgeneric database-query-result-set + (query-expression database &optional full-set) + (:method (query-expression (database closed-database) &optional full-set) + (declare (ignore query-expression full-set)) + (signal-closed-database-error database) + (values nil nil nil)) + (:documentation + "Internal generic implementation of query mapping. Starts the +query specified by query-expression on the given database and returns +a result-set to be used with database-store-next-row and +database-dump-result-set to access the returned data. The second +value is the number of columns in the result-set, if there are any. +If full-set is true, the number of rows in the result-set is returned +as a third value, if this is possible (otherwise nil is returned for +the third value). This might have memory and resource usage +implications, since many databases will require the query to be +executed in full to answer this question. If the query produced no +results then nil is returned for all values that would have been +returned otherwise. If an error occurs during query execution, the +function should signal a clsql-sql-error.")) + +(defgeneric database-dump-result-set (result-set database) + (:method (result-set (database closed-database)) + (declare (ignore result-set)) + (signal-closed-database-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)) + (:documentation + "Returns t and stores the next row in the result set in list or +returns nil when result-set is finished.")) + + + +(defun map-query (output-type-spec function query-expression + &key (database *default-database*)) + "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)) + (list (map-query-to-list function query-expression database)) + ((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)) + (t + (funcall #'map-query (cmucl-compat:result-type-or-lose output-type-spec t) + function query-expression :database database))))) + +(defun map-query-for-effect (function query-expression database) + (multiple-value-bind (result-set columns) + (database-query-result-set query-expression database) + (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) + (multiple-value-bind (result-set columns) + (database-query-result-set query-expression database) + (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) + (multiple-value-bind (result-set columns rows) + (database-query-result-set query-expression database t) + (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*)) + &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) + (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))))))) + + + diff --git a/test-clsql.cl b/test-clsql.cl new file mode 100644 index 0000000..7d46988 --- /dev/null +++ b/test-clsql.cl @@ -0,0 +1,97 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: test-clsql.cl +;;;; Purpose: Basic test of CLSQL +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id: test-clsql.cl,v 1.1 2002/03/23 14:04:49 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) + +(defun get-spec-and-type () + (format t "~&Test CLSQL") + (format t "~&==========~%") + (format t "~&Enter connection type (:mysql :postgresql :postgresql-socket") + #+allegro (format t " :aodbc") + (format t ") [default END]: ") + (let ((type-string (read-line))) + (if (zerop (length type-string)) + (values nil nil) + (let* ((type (read-from-string type-string)) + (spec (get-spec type + (ecase type + ((:mysql :postgresql :postgresql-socket) + '("host" "database" "user" "password")) + (:aodbc + '("dsn" "user" "password")))))) + (when (eq type :mysql) + (test-clsql-mysql spec)) + (values spec type))))) + + +(defun get-spec (type spec-format) + (let (spec) + (format t "~&Connection Spec for ~A" (symbol-name type)) + (format t "~&------------------------------") + + (dolist (elem spec-format) + (format t "~&Enter ~A: " elem) + (push (read-line) spec)) + (nreverse spec))) + +(defun test-clsql (spec type) + (let ((db (clsql:connect spec :database-type type :if-exists :new))) + (unwind-protect + (progn + (ignore-errors + (clsql:execute-command + "DROP TABLE test_clsql" :database db)) + (clsql:execute-command + "CREATE TABLE test_clsql (i integer, sqrt float, sqrt_str CHAR(20))" :database db) + (dotimes (i 10) + (clsql:execute-command + (format nil "INSERT INTO test_clsql VALUES (~d,~d,'~a')" + i (sqrt i) (format nil "~d" (sqrt i))) + :database db)) + (pprint (clsql:map-query 'vector #'list "select * from test_clsql" :database db)) + (clsql:execute-command "DROP TABLE test_clsql")) + (clsql:disconnect :database db))) + ) + +(defun test-clsql-mysql (spec) + (let ((db (clsql-mysql::database-connect spec :mysql))) + (clsql-mysql::database-execute-command "DROP TABLE IF EXISTS test_clsql" db) + (clsql-mysql::database-execute-command + "CREATE TABLE test_clsql (i integer, sqrt double, sqrt_str CHAR(20))" db) + (dotimes (i 10) + (clsql-mysql::database-execute-command + (format nil "INSERT INTO test_clsql VALUES (~d,~d,'~a')" + i (sqrt i) (format nil "~d" (sqrt i))) + db)) + (let ((res (clsql-mysql::database-query-result-set "select * from test_clsql" db t))) + (format t "~&Number rows: ~D~%" (mysql:mysql-num-rows (clsql-mysql::mysql-result-set-res-ptr res))) + (clsql-mysql::database-dump-result-set res db)) + (clsql-mysql::database-execute-command "DROP TABLE test_clsql" db) + (clsql-mysql::database-disconnect db))) + + +(do ((done nil)) + (done) + (multiple-value-bind (spec type) (get-spec-and-type) + (if spec + (test-clsql spec type) + (setq done t)))) + + + -- 2.34.1