From: Kevin M. Rosenberg Date: Sat, 23 Mar 2002 14:04:48 +0000 (+0000) Subject: r1639: Initial revision X-Git-Tag: v3.8.6~1234 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=8213ff48f5362c3d4792444c929f50bd128bd044 r1639: Initial revision --- 8213ff48f5362c3d4792444c929f50bd128bd044 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)))) + + +