From: Kevin M. Rosenberg Date: Mon, 30 Sep 2002 10:19:24 +0000 (+0000) Subject: r2914: rename .cl files X-Git-Tag: v3.8.6~915 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=7d50938ba2db52a713498e49aa1679deae6f0b6b r2914: rename .cl files --- diff --git a/clsql-aodbc.asd b/clsql-aodbc.asd index 8f3a961..a996f85 100644 --- a/clsql-aodbc.asd +++ b/clsql-aodbc.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Aug 2002 ;;;; -;;;; $Id: clsql-aodbc.asd,v 1.11 2002/09/25 12:44:59 kevin Exp $ +;;;; $Id: clsql-aodbc.asd,v 1.12 2002/09/30 10:19:23 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -34,9 +34,3 @@ ((:file "aodbc-package") (:file "aodbc-sql" :depends-on ("aodbc-package"))))) :depends-on (:clsql-base)) - -#+(and allegro (not allegro-cl-trial)) -(defmethod source-file-type ((c cl-source-file) - (s (eql (find-system :clsql-aodbc)))) - "cl") - diff --git a/clsql-base.asd b/clsql-base.asd index 9ac0fde..dcb0e28 100644 --- a/clsql-base.asd +++ b/clsql-base.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: clsql-base.asd,v 1.14 2002/09/25 12:44:59 kevin Exp $ +;;;; $Id: clsql-base.asd,v 1.15 2002/09/30 10:19:23 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -41,11 +41,6 @@ (:file "db-interface" :depends-on ("conditions")) (:file "initialize" :depends-on ("db-interface")))))) -#+(or allegro lispworks cmu openmcl mcl) -(defmethod source-file-type ((c cl-source-file) - (s (eql (find-system :clsql-base)))) - "cl") - #+(or allegro lispworks cmu openmcl mcl) (when (ignore-errors (find-class 'load-compiled-op)) (defmethod perform :after ((op load-compiled-op) (c (eql (find-system :clsql-base)))) diff --git a/clsql-mysql.asd b/clsql-mysql.asd index 975c588..8b440c1 100644 --- a/clsql-mysql.asd +++ b/clsql-mysql.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Aug 2002 ;;;; -;;;; $Id: clsql-mysql.asd,v 1.10 2002/09/25 12:44:59 kevin Exp $ +;;;; $Id: clsql-mysql.asd,v 1.11 2002/09/30 10:19:23 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -39,8 +39,3 @@ (:file "mysql-sql" :depends-on ("mysql-api")) (:file "mysql-usql" :depends-on ("mysql-sql"))))) :depends-on (:uffi :clsql-base :clsql-uffi)) - -#+(or allegro lispworks cmu openmcl mcl) -(defmethod source-file-type ((c cl-source-file) - (s (eql (find-system :clsql-mysql)))) - "cl") diff --git a/clsql-oracle.asd b/clsql-oracle.asd index e8b9f98..56707a0 100644 --- a/clsql-oracle.asd +++ b/clsql-oracle.asd @@ -1,7 +1,7 @@ ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; This is copyrighted software. See interfaces/oracle/* files for terms. ;;;; -;;;; $Id: clsql-oracle.asd,v 1.9 2002/09/25 12:44:59 kevin Exp $ +;;;; $Id: clsql-oracle.asd,v 1.10 2002/09/30 10:19:23 kevin Exp $ (in-package :asdf) @@ -28,11 +28,3 @@ (:file "oracle-sql" :depends-on ("oracle" "alien-resources")) (:file "oracle-objects" :depends-on ("oracle-sql"))))) :depends-on (:clsql-base)) - -#+(or allegro lispworks cmu openmcl mcl) -(defmethod source-file-type ((c cl-source-file) - (s (eql (find-system :clsql-oracle)))) - "cl") - - - diff --git a/clsql-postgresql-socket.asd b/clsql-postgresql-socket.asd index 5cc71c8..4504817 100644 --- a/clsql-postgresql-socket.asd +++ b/clsql-postgresql-socket.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Aug 2002 ;;;; -;;;; $Id: clsql-postgresql-socket.asd,v 1.10 2002/09/25 12:44:59 kevin Exp $ +;;;; $Id: clsql-postgresql-socket.asd,v 1.11 2002/09/30 10:19:23 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -39,9 +39,3 @@ (:file "postgresql-socket-sql" :depends-on ("postgresql-socket-api"))))) :depends-on (:clsql-base :uffi)) - -#+(or allegro lispworks cmu openmcl mcl) -(defmethod source-file-type ((c cl-source-file) - (s (eql (find-system :clsql-postgresql-socket)))) - "cl") - diff --git a/clsql-postgresql.asd b/clsql-postgresql.asd index fb61b84..f377ddd 100644 --- a/clsql-postgresql.asd +++ b/clsql-postgresql.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Aug 2002 ;;;; -;;;; $Id: clsql-postgresql.asd,v 1.10 2002/09/25 12:44:59 kevin Exp $ +;;;; $Id: clsql-postgresql.asd,v 1.11 2002/09/30 10:19:23 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -38,8 +38,3 @@ (:file "postgresql-sql" :depends-on ("postgresql-api")) (:file "postgresql-usql" :depends-on ("postgresql-sql"))))) :depends-on (:uffi :clsql-base :clsql-uffi)) - -#+(or allegro lispworks cmu openmcl mcl) -(defmethod source-file-type ((c cl-source-file) - (s (eql (find-system :clsql-postgresql)))) - "cl") diff --git a/clsql-uffi.asd b/clsql-uffi.asd index 8c6918b..e5e726d 100644 --- a/clsql-uffi.asd +++ b/clsql-uffi.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Aug 2002 ;;;; -;;;; $Id: clsql-uffi.asd,v 1.11 2002/09/25 12:44:59 kevin Exp $ +;;;; $Id: clsql-uffi.asd,v 1.12 2002/09/30 10:19:23 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -39,9 +39,3 @@ (:file "clsql-uffi-loader" :depends-on ("clsql-uffi-package")) (:file "clsql-uffi" :depends-on ("clsql-uffi-loader"))))) :depends-on (:uffi :clsql-base)) - - -#+(or allegro lispworks cmu openmcl mcl) -(defmethod source-file-type ((c cl-source-file) - (s (eql (find-system :clsql-uffi)))) - "cl") diff --git a/clsql.asd b/clsql.asd index 0c7c27d..f4a609d 100644 --- a/clsql.asd +++ b/clsql.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: clsql.asd,v 1.12 2002/09/25 12:44:59 kevin Exp $ +;;;; $Id: clsql.asd,v 1.13 2002/09/30 10:19:23 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -43,12 +43,6 @@ :depends-on (:clsql-base) ) -#+(or allegro lispworks cmu openmcl mcl) -(defmethod source-file-type ((c cl-source-file) - (s (eql (find-system :clsql)))) - "cl") - - #+(or allegro lispworks cmu openmcl mcl) (when (ignore-errors (find-class 'load-compiled-op)) (defmethod perform :after ((op load-compiled-op) (c (eql (find-system :clsql)))) diff --git a/db-aodbc/aodbc-package.cl b/db-aodbc/aodbc-package.cl deleted file mode 100644 index f00e0f2..0000000 --- a/db-aodbc/aodbc-package.cl +++ /dev/null @@ -1,31 +0,0 @@ -;;;; -*- 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/09/18 07:43:40 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-base-sys) - (:export #:aodbc-database) - (:documentation "This is the CLSQL interface to Allegro's AODBC")) diff --git a/db-aodbc/aodbc-package.lisp b/db-aodbc/aodbc-package.lisp new file mode 100644 index 0000000..413ba7b --- /dev/null +++ b/db-aodbc/aodbc-package.lisp @@ -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.lisp,v 1.1 2002/09/30 10:19:23 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-base-sys) + (:export #:aodbc-database) + (:documentation "This is the CLSQL interface to Allegro's AODBC")) diff --git a/db-aodbc/aodbc-sql.cl b/db-aodbc/aodbc-sql.cl deleted file mode 100644 index b4b5403..0000000 --- a/db-aodbc/aodbc-sql.cl +++ /dev/null @@ -1,150 +0,0 @@ -;;;; -*- 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/09/18 07:43:40 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) - - -;; interface foreign library loading routines -(defmethod database-type-library-loaded ((database-type (eql :aodbc))) - "T if foreign library was able to be loaded successfully. " - (when (find-package :dbi) ;; finds Allegro's DBI (AODBC) package - t)) - -(defmethod clsql-base-sys:database-type-load-foreign ((databae-type (eql :aodbc))) - t) - -(when (find-package :dbi) - (clsql-base-sys:database-type-load-foreign :aodbc)) - -(defmethod database-initialize-database-type ((database-type (eql :aodbc))) - t) - - -;; AODBC interface - -(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)) - #+aodbc-v2 - (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)) - #+aodbc-v2 - (dbi:disconnect (database-aodbc-conn database)) - (setf (database-aodbc-conn database) nil) - t) - -(defmethod database-query (query-expression (database aodbc-database) types) - #+aodbc-v2 - (handler-case - (dbi:sql query-expression :db (database-aodbc-conn database) - :types types) - (error () - (error 'clsql-sql-error - :database database - :expression query-expression - :errno nil - :error "Query failed")))) - -(defmethod database-execute-command (sql-expression - (database aodbc-database)) - #+aodbc-v2 - (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) - (types nil :type cons) - (full-set nil :type boolean)) - -(defmethod database-query-result-set (query-expression (database aodbc-database) - &key full-set types) - #+aodbc-v2 - (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 - :types types - ) - (values - (make-aodbc-result-set :query query :full-set full-set - :types types) - (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)) - #+aodbc-v2 - (dbi:close-query (aodbc-result-set-query result-set)) - t) - -(defmethod database-store-next-row (result-set - (database aodbc-database) - list) - #+aodbc-v2 - (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)))) - - -(when (clsql-base-sys:database-type-library-loaded :aodbc) - (clsql-base-sys:initialize-database-type :database-type :aodbc)) diff --git a/db-aodbc/aodbc-sql.lisp b/db-aodbc/aodbc-sql.lisp new file mode 100644 index 0000000..641764b --- /dev/null +++ b/db-aodbc/aodbc-sql.lisp @@ -0,0 +1,150 @@ +;;;; -*- 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.lisp,v 1.1 2002/09/30 10:19:23 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) + + +;; interface foreign library loading routines +(defmethod database-type-library-loaded ((database-type (eql :aodbc))) + "T if foreign library was able to be loaded successfully. " + (when (find-package :dbi) ;; finds Allegro's DBI (AODBC) package + t)) + +(defmethod clsql-base-sys:database-type-load-foreign ((databae-type (eql :aodbc))) + t) + +(when (find-package :dbi) + (clsql-base-sys:database-type-load-foreign :aodbc)) + +(defmethod database-initialize-database-type ((database-type (eql :aodbc))) + t) + + +;; AODBC interface + +(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)) + #+aodbc-v2 + (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)) + #+aodbc-v2 + (dbi:disconnect (database-aodbc-conn database)) + (setf (database-aodbc-conn database) nil) + t) + +(defmethod database-query (query-expression (database aodbc-database) types) + #+aodbc-v2 + (handler-case + (dbi:sql query-expression :db (database-aodbc-conn database) + :types types) + (error () + (error 'clsql-sql-error + :database database + :expression query-expression + :errno nil + :error "Query failed")))) + +(defmethod database-execute-command (sql-expression + (database aodbc-database)) + #+aodbc-v2 + (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) + (types nil :type cons) + (full-set nil :type boolean)) + +(defmethod database-query-result-set (query-expression (database aodbc-database) + &key full-set types) + #+aodbc-v2 + (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 + :types types + ) + (values + (make-aodbc-result-set :query query :full-set full-set + :types types) + (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)) + #+aodbc-v2 + (dbi:close-query (aodbc-result-set-query result-set)) + t) + +(defmethod database-store-next-row (result-set + (database aodbc-database) + list) + #+aodbc-v2 + (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)))) + + +(when (clsql-base-sys:database-type-library-loaded :aodbc) + (clsql-base-sys:initialize-database-type :database-type :aodbc)) diff --git a/db-mysql/mysql-api.cl b/db-mysql/mysql-api.cl deleted file mode 100644 index b58c8b0..0000000 --- a/db-mysql/mysql-api.cl +++ /dev/null @@ -1,586 +0,0 @@ -;;;; -*- 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-api.cl,v 1.3 2002/09/30 02:45:16 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 (:struct-pointer mysql-used-mem)) - (used (:struct-pointer mysql-used-mem)) - (pre-alloc (:struct-pointer 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-array-pointer mysql-field-vector (* mysql-field)) - -(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 (:struct-pointer mysql-rows)) - -(uffi:def-struct mysql-data - (rows-high32 :unsigned-long) - (rows-low32 :unsigned-long) - (fields :unsigned-int) - (data (:struct-pointer mysql-rows)) - (alloc (:struct 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 (:struct 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 (:struct-pointer mysql-field)) - (field-alloc (:struct mysql-mem-root)) - (free-me mysql-bool) - (reconnect mysql-bool) - (options (:struct 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 (:struct-pointer mysql-field)) - (data (:struct-pointer mysql-data)) - (data-cursor (:struct-pointer mysql-rows)) - (field-alloc (:struct mysql-mem-root)) - (row mysql-row) - (current-row mysql-row) - (lengths (* :unsigned-long)) - (handle (:struct-pointer 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)) - -;; Need to comment this out for LW 4.2.6 -;; ? bug in LW version -;;(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 (* (* :unsigned-char))) - -(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-fetch-fields)) -(uffi:def-function "mysql_fetch_fields" - ((res (* mysql-mysql-res))) - :module "mysql" - :returning (* mysql-field)) - -(declaim (inline mysql-fetch-field-direct)) -(uffi:def-function "mysql_fetch_field_direct" - ((res (* mysql-mysql-res)) - (field-num :unsigned-int)) - :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 - - -(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) - - -(defun mysql-data-seek (res offset) - (multiple-value-bind (high32 low32) (split-64-bit-integer offset) - (clsql-mysql-data-seek res high32 low32))) diff --git a/db-mysql/mysql-api.lisp b/db-mysql/mysql-api.lisp new file mode 100644 index 0000000..6842f8b --- /dev/null +++ b/db-mysql/mysql-api.lisp @@ -0,0 +1,586 @@ +;;;; -*- 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-api.lisp,v 1.1 2002/09/30 10:19:23 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 (:struct-pointer mysql-used-mem)) + (used (:struct-pointer mysql-used-mem)) + (pre-alloc (:struct-pointer 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-array-pointer mysql-field-vector (* mysql-field)) + +(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 (:struct-pointer mysql-rows)) + +(uffi:def-struct mysql-data + (rows-high32 :unsigned-long) + (rows-low32 :unsigned-long) + (fields :unsigned-int) + (data (:struct-pointer mysql-rows)) + (alloc (:struct 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 (:struct 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 (:struct-pointer mysql-field)) + (field-alloc (:struct mysql-mem-root)) + (free-me mysql-bool) + (reconnect mysql-bool) + (options (:struct 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 (:struct-pointer mysql-field)) + (data (:struct-pointer mysql-data)) + (data-cursor (:struct-pointer mysql-rows)) + (field-alloc (:struct mysql-mem-root)) + (row mysql-row) + (current-row mysql-row) + (lengths (* :unsigned-long)) + (handle (:struct-pointer 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)) + +;; Need to comment this out for LW 4.2.6 +;; ? bug in LW version +;;(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 (* (* :unsigned-char))) + +(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-fetch-fields)) +(uffi:def-function "mysql_fetch_fields" + ((res (* mysql-mysql-res))) + :module "mysql" + :returning (* mysql-field)) + +(declaim (inline mysql-fetch-field-direct)) +(uffi:def-function "mysql_fetch_field_direct" + ((res (* mysql-mysql-res)) + (field-num :unsigned-int)) + :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 + + +(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) + + +(defun mysql-data-seek (res offset) + (multiple-value-bind (high32 low32) (split-64-bit-integer offset) + (clsql-mysql-data-seek res high32 low32))) diff --git a/db-mysql/mysql-loader.cl b/db-mysql/mysql-loader.cl deleted file mode 100644 index 14c9d9f..0000000 --- a/db-mysql/mysql-loader.cl +++ /dev/null @@ -1,95 +0,0 @@ -;;;; -*- 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.3 2002/09/30 05:32:35 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* - (uffi:find-foreign-library - "clsql-mysql" - `("/usr/lib/clsql/" - "/opt/lisp/clsql/db-mysql/" - "/home/kevin/debian/src/clsql/db-mysql/") - :drive-letters '("C" "D" "E" "F" "G"))) - -(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-library-candidate-names* - '("libmysqlclient" "libmysql")) - -(defvar *mysql-library-candidate-directories* - '("/opt/mysql/lib/mysql/" "/usr/local/lib/" "/usr/lib/" "/mysql/lib/opt/")) - -(defvar *mysql-library-candidate-drive-letters* '("C" "D" "E")) - -(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.") - -(defvar *mysql-library-loaded* nil - "T if foreign library was able to be loaded successfully") - -(defmethod clsql-base-sys:database-type-library-loaded ((database-type (eql :mysql))) - *mysql-library-loaded*) - -(defmethod clsql-base-sys:database-type-load-foreign ((database-type (eql :mysql))) - (let ((mysql-path - (uffi:find-foreign-library *mysql-library-candidate-names* - *mysql-library-candidate-directories* - :drive-letters - *mysql-library-candidate-drive-letters*))) - ;; zlib required to load mysql on CMUCL Solaris - (uffi:load-foreign-library - (uffi:find-foreign-library '("libz" "zlib") - '("/usr/lib/" "/usr/local/" "/lib/"))) - (if (and - (uffi:load-foreign-library mysql-path - :module "mysql" - :supporting-libraries - *mysql-supporting-libraries*) - (uffi:load-foreign-library *clsql-mysql-library-filename* - :module "clsql-mysql" - :supporting-libraries - (append *mysql-supporting-libraries*))) - (setq *mysql-library-loaded* t) - (warn "Unable to load MySQL client library ~A or CLSQL-MySQL library ~A" - mysql-path *clsql-mysql-library-filename*)))) - - -(clsql-base-sys:database-type-load-foreign :mysql) - diff --git a/db-mysql/mysql-loader.lisp b/db-mysql/mysql-loader.lisp new file mode 100644 index 0000000..b0c9c14 --- /dev/null +++ b/db-mysql/mysql-loader.lisp @@ -0,0 +1,95 @@ +;;;; -*- 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.lisp,v 1.1 2002/09/30 10:19:23 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* + (uffi:find-foreign-library + "clsql-mysql" + `("/usr/lib/clsql/" + "/opt/lisp/clsql/db-mysql/" + "/home/kevin/debian/src/clsql/db-mysql/") + :drive-letters '("C" "D" "E" "F" "G"))) + +(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-library-candidate-names* + '("libmysqlclient" "libmysql")) + +(defvar *mysql-library-candidate-directories* + '("/opt/mysql/lib/mysql/" "/usr/local/lib/" "/usr/lib/" "/mysql/lib/opt/")) + +(defvar *mysql-library-candidate-drive-letters* '("C" "D" "E")) + +(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.") + +(defvar *mysql-library-loaded* nil + "T if foreign library was able to be loaded successfully") + +(defmethod clsql-base-sys:database-type-library-loaded ((database-type (eql :mysql))) + *mysql-library-loaded*) + +(defmethod clsql-base-sys:database-type-load-foreign ((database-type (eql :mysql))) + (let ((mysql-path + (uffi:find-foreign-library *mysql-library-candidate-names* + *mysql-library-candidate-directories* + :drive-letters + *mysql-library-candidate-drive-letters*))) + ;; zlib required to load mysql on CMUCL Solaris + (uffi:load-foreign-library + (uffi:find-foreign-library '("libz" "zlib") + '("/usr/lib/" "/usr/local/" "/lib/"))) + (if (and + (uffi:load-foreign-library mysql-path + :module "mysql" + :supporting-libraries + *mysql-supporting-libraries*) + (uffi:load-foreign-library *clsql-mysql-library-filename* + :module "clsql-mysql" + :supporting-libraries + (append *mysql-supporting-libraries*))) + (setq *mysql-library-loaded* t) + (warn "Unable to load MySQL client library ~A or CLSQL-MySQL library ~A" + mysql-path *clsql-mysql-library-filename*)))) + + +(clsql-base-sys:database-type-load-foreign :mysql) + diff --git a/db-mysql/mysql-package.cl b/db-mysql/mysql-package.cl deleted file mode 100644 index fcb3623..0000000 --- a/db-mysql/mysql-package.cl +++ /dev/null @@ -1,132 +0,0 @@ -;;;; -*- 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/09/18 07:43:40 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 :clsql-uffi) - (:export - #:database-library-loaded - - #: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-field-vector - #: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-fetch-fields - #:mysql-fetch-field-direct - #: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 - - #:make-64-bit-integer - ) - (:documentation "This is the low-level interface MySQL.")) diff --git a/db-mysql/mysql-package.lisp b/db-mysql/mysql-package.lisp new file mode 100644 index 0000000..95499be --- /dev/null +++ b/db-mysql/mysql-package.lisp @@ -0,0 +1,132 @@ +;;;; -*- 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.lisp,v 1.1 2002/09/30 10:19:23 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 :clsql-uffi) + (:export + #:database-library-loaded + + #: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-field-vector + #: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-fetch-fields + #:mysql-fetch-field-direct + #: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 + + #:make-64-bit-integer + ) + (:documentation "This is the low-level interface MySQL.")) diff --git a/db-mysql/mysql-sql.cl b/db-mysql/mysql-sql.cl deleted file mode 100644 index 4d7102a..0000000 --- a/db-mysql/mysql-sql.cl +++ /dev/null @@ -1,260 +0,0 @@ -;;;; -*- 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.3 2002/09/30 02:07:42 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. -;;;; -;;;; Mar 2002 -;;;; Added field types - -(defpackage :clsql-mysql - (:use :common-lisp :clsql-base-sys :mysql :clsql-uffi) - (:export #:mysql-database) - (:documentation "This is the CLSQL interface to MySQL.")) - -(in-package :clsql-mysql) - -;;; Field conversion functions - -(defun make-type-list-for-auto (num-fields res-ptr) - (let ((new-types '()) - #+ignore (field-vec (mysql-fetch-fields res-ptr))) - (dotimes (i num-fields) - (declare (fixnum i)) - (let* ( (field (mysql-fetch-field-direct res-ptr i)) - #+ignore (field (uffi:deref-array field-vec '(:array mysql-field) i)) - (type (uffi:get-slot-value field 'mysql-field 'type))) - (push - (case type - ((#.mysql-field-types#tiny - #.mysql-field-types#short - #.mysql-field-types#int24 - #.mysql-field-types#long) - :int32) - (#.mysql-field-types#longlong - :int64) - ((#.mysql-field-types#double - #.mysql-field-types#float - #.mysql-field-types#decimal) - :double) - (otherwise - t)) - new-types))) - (nreverse new-types))) - -(defun canonicalize-types (types num-fields res-ptr) - (if (null types) - nil - (let ((auto-list (make-type-list-for-auto num-fields res-ptr))) - (cond - ((listp types) - (canonicalize-type-list types auto-list)) - ((eq types :auto) - auto-list) - (t - nil))))) - -(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-type ((database mysql-database)) - :mysql) - -(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-cstrings ((host-native host) - (user-native user) - (password-native password) - (db-native db) - (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) - :connection-spec connection-spec - :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) - - -(defmethod database-query (query-expression (database mysql-database) - types) - (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 - (let ((num-fields (mysql-num-fields res-ptr))) - (setq types (canonicalize-types - types num-fields - 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 num-fields - collect - (convert-raw-field - (uffi:deref-array row '(:array (* :unsigned-char)) i) - types 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-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)))))) - -(defstruct mysql-result-set - (res-ptr (uffi:make-null-pointer 'mysql-mysql-res) - :type mysql-mysql-res-ptr-def) - (types nil) - (num-fields nil :type fixnum) - (full-set nil :type boolean)) - - -(defmethod database-query-result-set (query-expression - (database mysql-database) - &key full-set types) - (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)) - (let* ((num-fields (mysql-num-fields res-ptr)) - (result-set (make-mysql-result-set - :res-ptr res-ptr - :num-fields num-fields - :full-set full-set - :types - (canonicalize-types - types num-fields - res-ptr)))) - (if full-set - (values result-set - num-fields - (mysql-num-rows res-ptr)) - (values result-set - num-fields))) - (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-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)) - (types (mysql-result-set-types result-set))) - (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-result-set-num-fields result-set) - for rest on list - do - (setf (car rest) - (convert-raw-field - (uffi:deref-array row '(:array (* :unsigned-char)) i) - types - i))) - list))) - - -(when (clsql-base-sys:database-type-library-loaded :mysql) - (clsql-base-sys:initialize-database-type :database-type :mysql) - (pushnew :mysql cl:*features*)) diff --git a/db-mysql/mysql-sql.lisp b/db-mysql/mysql-sql.lisp new file mode 100644 index 0000000..472d810 --- /dev/null +++ b/db-mysql/mysql-sql.lisp @@ -0,0 +1,260 @@ +;;;; -*- 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.lisp,v 1.1 2002/09/30 10:19:23 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. +;;;; +;;;; Mar 2002 +;;;; Added field types + +(defpackage :clsql-mysql + (:use :common-lisp :clsql-base-sys :mysql :clsql-uffi) + (:export #:mysql-database) + (:documentation "This is the CLSQL interface to MySQL.")) + +(in-package :clsql-mysql) + +;;; Field conversion functions + +(defun make-type-list-for-auto (num-fields res-ptr) + (let ((new-types '()) + #+ignore (field-vec (mysql-fetch-fields res-ptr))) + (dotimes (i num-fields) + (declare (fixnum i)) + (let* ( (field (mysql-fetch-field-direct res-ptr i)) + #+ignore (field (uffi:deref-array field-vec '(:array mysql-field) i)) + (type (uffi:get-slot-value field 'mysql-field 'type))) + (push + (case type + ((#.mysql-field-types#tiny + #.mysql-field-types#short + #.mysql-field-types#int24 + #.mysql-field-types#long) + :int32) + (#.mysql-field-types#longlong + :int64) + ((#.mysql-field-types#double + #.mysql-field-types#float + #.mysql-field-types#decimal) + :double) + (otherwise + t)) + new-types))) + (nreverse new-types))) + +(defun canonicalize-types (types num-fields res-ptr) + (if (null types) + nil + (let ((auto-list (make-type-list-for-auto num-fields res-ptr))) + (cond + ((listp types) + (canonicalize-type-list types auto-list)) + ((eq types :auto) + auto-list) + (t + nil))))) + +(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-type ((database mysql-database)) + :mysql) + +(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-cstrings ((host-native host) + (user-native user) + (password-native password) + (db-native db) + (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) + :connection-spec connection-spec + :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) + + +(defmethod database-query (query-expression (database mysql-database) + types) + (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 + (let ((num-fields (mysql-num-fields res-ptr))) + (setq types (canonicalize-types + types num-fields + 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 num-fields + collect + (convert-raw-field + (uffi:deref-array row '(:array (* :unsigned-char)) i) + types 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-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)))))) + +(defstruct mysql-result-set + (res-ptr (uffi:make-null-pointer 'mysql-mysql-res) + :type mysql-mysql-res-ptr-def) + (types nil) + (num-fields nil :type fixnum) + (full-set nil :type boolean)) + + +(defmethod database-query-result-set (query-expression + (database mysql-database) + &key full-set types) + (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)) + (let* ((num-fields (mysql-num-fields res-ptr)) + (result-set (make-mysql-result-set + :res-ptr res-ptr + :num-fields num-fields + :full-set full-set + :types + (canonicalize-types + types num-fields + res-ptr)))) + (if full-set + (values result-set + num-fields + (mysql-num-rows res-ptr)) + (values result-set + num-fields))) + (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-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)) + (types (mysql-result-set-types result-set))) + (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-result-set-num-fields result-set) + for rest on list + do + (setf (car rest) + (convert-raw-field + (uffi:deref-array row '(:array (* :unsigned-char)) i) + types + i))) + list))) + + +(when (clsql-base-sys:database-type-library-loaded :mysql) + (clsql-base-sys:initialize-database-type :database-type :mysql) + (pushnew :mysql cl:*features*)) diff --git a/db-mysql/mysql-usql.cl b/db-mysql/mysql-usql.cl deleted file mode 100644 index 0b56732..0000000 --- a/db-mysql/mysql-usql.cl +++ /dev/null @@ -1,105 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: mysql-usql.cl -;;;; Purpose: MySQL interface functions to support UncommonSQL -;;;; Programmers: Kevin M. Rosenberg and onShore Development Inc -;;;; Date Started: Mar 2002 -;;;; -;;;; $Id: mysql-usql.cl,v 1.1 2002/09/18 07:43:40 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; and by onShore Development Inc. -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-mysql) - -;; Table and attribute introspection - -(defmethod database-list-tables ((database mysql-database) - &key (system-tables nil)) - (declare (ignore system-tables)) - (mapcar #'car (database-query "show tables" database :auto))) - - -(defmethod database-list-attributes ((table string) (database mysql-database)) - (mapcar #'car - (database-query - (format nil "SHOW COLUMNS FROM ~A" table) - database nil))) - -(defmethod database-attribute-type (attribute (table string) - (database mysql-database)) - (let ((result - (mapcar #'cadr - (database-query - (format nil - "SHOW COLUMNS FROM ~A LIKE '~A'" table attribute) - database nil)))) - (let* ((str (car result)) - (end-str (position #\( str)) - (substr (subseq str 0 end-str))) - (if substr - (intern (string-upcase substr) :keyword) nil)))) - -;;; Sequence functions - -(defun %sequence-name-to-table (sequence-name) - (concatenate 'string "_usql_seq_" (sql-escape sequence-name))) - -(defmethod database-create-sequence (sequence-name - (database mysql-database)) - (let ((table-name (%sequence-name-to-table sequence-name))) - (database-execute-command - (concatenate 'string "CREATE TABLE " table-name - " (id int NOT NULL PRIMARY KEY AUTO_INCREMENT)") - database) - (database-execute-command - (concatenate 'string "INSERT INTO " table-name - " VALUES (0)") - database))) - -(defmethod database-drop-sequence (sequence-name - (database mysql-database)) - (database-execute-command - (concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name)) - database)) - -(defmethod database-sequence-next (sequence-name (database mysql-database)) - (database-execute-command - (concatenate 'string "UPDATE " (%sequence-name-to-table sequence-name) - " SET id=LAST_INSERT_ID(id+1)") - database) - (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database))) - -;; Misc USQL functions - -#| -#+ignore -(defmethod database-output-sql ((expr clsql-sys::sql-typecast-exp) - (database mysql-database)) - (with-slots (clsql-sys::modifier clsql-sys::components) - expr - (if clsql-sys::modifier - (progn - (clsql-sys::output-sql clsql-sys::components database) - (write-char #\: sql-sys::*sql-stream*) - (write-char #\: sql-sys::*sql-stream*) - (write-string (symbol-name clsql-sys::modifier) - clsql-sys::*sql-stream*))))) - -#+ignore -(defmethod database-output-sql-as-type ((type (eql 'integer)) val - (database mysql-database)) - ;; typecast it so it uses the indexes - (when val - (make-instance 'clsql-sys::sql-typecast-exp - :modifier 'int8 - :components val))) -|# diff --git a/db-mysql/mysql-usql.lisp b/db-mysql/mysql-usql.lisp new file mode 100644 index 0000000..dc3ea83 --- /dev/null +++ b/db-mysql/mysql-usql.lisp @@ -0,0 +1,105 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: mysql-usql.cl +;;;; Purpose: MySQL interface functions to support UncommonSQL +;;;; Programmers: Kevin M. Rosenberg and onShore Development Inc +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id: mysql-usql.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; and by onShore Development Inc. +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :clsql-mysql) + +;; Table and attribute introspection + +(defmethod database-list-tables ((database mysql-database) + &key (system-tables nil)) + (declare (ignore system-tables)) + (mapcar #'car (database-query "show tables" database :auto))) + + +(defmethod database-list-attributes ((table string) (database mysql-database)) + (mapcar #'car + (database-query + (format nil "SHOW COLUMNS FROM ~A" table) + database nil))) + +(defmethod database-attribute-type (attribute (table string) + (database mysql-database)) + (let ((result + (mapcar #'cadr + (database-query + (format nil + "SHOW COLUMNS FROM ~A LIKE '~A'" table attribute) + database nil)))) + (let* ((str (car result)) + (end-str (position #\( str)) + (substr (subseq str 0 end-str))) + (if substr + (intern (string-upcase substr) :keyword) nil)))) + +;;; Sequence functions + +(defun %sequence-name-to-table (sequence-name) + (concatenate 'string "_usql_seq_" (sql-escape sequence-name))) + +(defmethod database-create-sequence (sequence-name + (database mysql-database)) + (let ((table-name (%sequence-name-to-table sequence-name))) + (database-execute-command + (concatenate 'string "CREATE TABLE " table-name + " (id int NOT NULL PRIMARY KEY AUTO_INCREMENT)") + database) + (database-execute-command + (concatenate 'string "INSERT INTO " table-name + " VALUES (0)") + database))) + +(defmethod database-drop-sequence (sequence-name + (database mysql-database)) + (database-execute-command + (concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name)) + database)) + +(defmethod database-sequence-next (sequence-name (database mysql-database)) + (database-execute-command + (concatenate 'string "UPDATE " (%sequence-name-to-table sequence-name) + " SET id=LAST_INSERT_ID(id+1)") + database) + (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database))) + +;; Misc USQL functions + +#| +#+ignore +(defmethod database-output-sql ((expr clsql-sys::sql-typecast-exp) + (database mysql-database)) + (with-slots (clsql-sys::modifier clsql-sys::components) + expr + (if clsql-sys::modifier + (progn + (clsql-sys::output-sql clsql-sys::components database) + (write-char #\: sql-sys::*sql-stream*) + (write-char #\: sql-sys::*sql-stream*) + (write-string (symbol-name clsql-sys::modifier) + clsql-sys::*sql-stream*))))) + +#+ignore +(defmethod database-output-sql-as-type ((type (eql 'integer)) val + (database mysql-database)) + ;; typecast it so it uses the indexes + (when val + (make-instance 'clsql-sys::sql-typecast-exp + :modifier 'int8 + :components val))) +|# diff --git a/db-mysql/testing/mysql-struct-size.cl b/db-mysql/testing/mysql-struct-size.cl deleted file mode 100644 index 60dfd92..0000000 --- a/db-mysql/testing/mysql-struct-size.cl +++ /dev/null @@ -1,11 +0,0 @@ -(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/db-mysql/testing/mysql-struct-size.lisp b/db-mysql/testing/mysql-struct-size.lisp new file mode 100644 index 0000000..60dfd92 --- /dev/null +++ b/db-mysql/testing/mysql-struct-size.lisp @@ -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/db-oracle/alien-resources.cl b/db-oracle/alien-resources.cl deleted file mode 100644 index 6848762..0000000 --- a/db-oracle/alien-resources.cl +++ /dev/null @@ -1,57 +0,0 @@ -;;; -*- Mode: Lisp -*- -;;; $Id: alien-resources.cl,v 1.1 2002/09/18 07:43:41 kevin Exp $ - -;;; This is copyrighted software. See documentation for terms. -;;; -;;; oracle-sql.lisp --- SQL-Interface implementation for Oracle -;;; -;;; derived from postgresql.lisp - -(in-package :clsql-oracle) - -(declaim (optimize (speed 3) - (debug 1))) - -(defparameter *alien-resource-hash* (make-hash-table :test #'equal)) - -(defun %get-resource (type sizeof) - (let ((resources (gethash type *alien-resource-hash*))) - (car (member-if - #'(lambda (res) - (and (= (alien-resource-sizeof res) sizeof) - (not (alien-resource-in-use res)))) - resources)))) - -(defun %insert-alien-resource (type res) - (let ((resource (gethash type *alien-resource-hash*))) - (setf (gethash type *alien-resource-hash*) - (cons res (gethash type *alien-resource-hash*))))) - -(defmacro acquire-alien-resource (type &optional size) - `(let ((res (%get-resource ',type ,size))) - (unless res - (setf res (make-alien-resource - :type ',type :sizeof ,size - :buffer (make-alien ,type ,size))) - (%insert-alien-resource ',type res)) - (claim-alien-resource res))) - -(defstruct (alien-resource) - (type (error "Missing TYPE.") - :read-only t) - (sizeof (error "Missing SIZEOF.") - :read-only t) - (buffer (error "Missing BUFFER.") - :read-only t) - (in-use nil :type boolean)) - -(defun free-alien-resource (ares) - (setf (alien-resource-in-use ares) nil) - ares) - -(defun claim-alien-resource (ares) - (setf (alien-resource-in-use ares) t) - ares) - - - diff --git a/db-oracle/alien-resources.lisp b/db-oracle/alien-resources.lisp new file mode 100644 index 0000000..97dafb6 --- /dev/null +++ b/db-oracle/alien-resources.lisp @@ -0,0 +1,57 @@ +;;; -*- Mode: Lisp -*- +;;; $Id: alien-resources.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $ + +;;; This is copyrighted software. See documentation for terms. +;;; +;;; oracle-sql.lisp --- SQL-Interface implementation for Oracle +;;; +;;; derived from postgresql.lisp + +(in-package :clsql-oracle) + +(declaim (optimize (speed 3) + (debug 1))) + +(defparameter *alien-resource-hash* (make-hash-table :test #'equal)) + +(defun %get-resource (type sizeof) + (let ((resources (gethash type *alien-resource-hash*))) + (car (member-if + #'(lambda (res) + (and (= (alien-resource-sizeof res) sizeof) + (not (alien-resource-in-use res)))) + resources)))) + +(defun %insert-alien-resource (type res) + (let ((resource (gethash type *alien-resource-hash*))) + (setf (gethash type *alien-resource-hash*) + (cons res (gethash type *alien-resource-hash*))))) + +(defmacro acquire-alien-resource (type &optional size) + `(let ((res (%get-resource ',type ,size))) + (unless res + (setf res (make-alien-resource + :type ',type :sizeof ,size + :buffer (make-alien ,type ,size))) + (%insert-alien-resource ',type res)) + (claim-alien-resource res))) + +(defstruct (alien-resource) + (type (error "Missing TYPE.") + :read-only t) + (sizeof (error "Missing SIZEOF.") + :read-only t) + (buffer (error "Missing BUFFER.") + :read-only t) + (in-use nil :type boolean)) + +(defun free-alien-resource (ares) + (setf (alien-resource-in-use ares) nil) + ares) + +(defun claim-alien-resource (ares) + (setf (alien-resource-in-use ares) t) + ares) + + + diff --git a/db-oracle/oracle-constants.cl b/db-oracle/oracle-constants.cl deleted file mode 100644 index 245a2b4..0000000 --- a/db-oracle/oracle-constants.cl +++ /dev/null @@ -1,530 +0,0 @@ -;;; -*- Mode: Lisp -*- -;;; $Id: oracle-constants.cl,v 1.1 2002/09/18 07:43:41 kevin Exp $ - -(in-package :clsql-oracle) - -(defconstant +oci-default+ #x00) ; default value for parameters and attributes -(defconstant +oci-threaded+ #x01) ; application is in threaded environment -(defconstant +oci-object+ #x02) ; the application is in object environment -(defconstant +oci-non-blocking+ #x04) ; non blocking mode of operation -(defconstant +oci-env-no-mutex+ #x08) ; the environment handle will not be protected by a mutex internally - -;; Handle types - -(defconstant +oci-htype-env+ 1) ; environment handle -(defconstant +oci-htype-error+ 2) ; error handle -(defconstant +oci-htype-svcctx+ 3) ; service handle -(defconstant +oci-htype-stmt+ 4) ; statement handle -(defconstant +oci-htype-bind+ 5) ; bind handle -(defconstant +oci-htype-define+ 6) ; define handle -(defconstant +oci-htype-describe+ 7) ; describe handle -(defconstant +oci-htype-server+ 8) ; server handle -(defconstant +oci-htype-session+ 9) ; authentication handle -(defconstant +oci-htype-trans+ 10) ; transaction handle -(defconstant +oci-htype-complexobject+ 11) ; complex object retrieval handle -(defconstant +oci-htype-security+ 12) ; security handle - -;; Descriptor types - -(defconstant +oci-dtype-lob+ 50) ; lob locator -(defconstant +oci-dtype-snap+ 51) ; snapshot -(defconstant +oci-dtype-rset+ 52) ; result set -(defconstant +oci-dtype-param+ 53) ; parameter descriptor obtained from ocigparm -(defconstant +oci-dtype-rowid+ 54) ; rowid -(defconstant +oci-dtype-complexobjectcomp+ 55) ; complex object retrieval descriptor -(defconstant +oci-dtype-file+ 56) ; File Lob locator -(defconstant +oci-dtype-aqenq-options+ 57) ; enqueue options -(defconstant +oci-dtype-aqdeq-options+ 58) ; dequeue options -(defconstant +oci-dtype-aqmsg-properties+ 59) ; message properties -(defconstant +oci-dtype-aqagent+ 60) ; aq agent - -;; Objectr pointer types - -(defconstant +oci-otype-name+ 1) ; object name -(defconstant +oci-otype-ref+ 2) ; REF to TDO -(defconstant +oci-otype-ptr+ 3) ; PTR to TDO - -;; Attribute types - -(defconstant +oci-attr-fncode+ 1) ; the OCI function code -(defconstant +oci-attr-object+ 2) ; is the environment initialized in object mode -(defconstant +oci-attr-nonblocking-mode+ 3) ; non blocking mode -(defconstant +oci-attr-sqlcode+ 4) ; the SQL verb -(defconstant +oci-attr-env+ 5) ; the environment handle -(defconstant +oci-attr-server+ 6) ; the server handle -(defconstant +oci-attr-session+ 7) ; the user session handle -(defconstant +oci-attr-trans+ 8) ; the transaction handle -(defconstant +oci-attr-row-count+ 9) ; the rows processed so far -(defconstant +oci-attr-sqlfncode+ 10) ; the SQL verb of the statement -(defconstant +oci-attr-prefetch-rows+ 11) ; sets the number of rows to prefetch -(defconstant +oci-attr-nested-prefetch-rows+ 12) ; the prefetch rows of nested table -(defconstant +oci-attr-prefetch-memory+ 13) ; memory limit for rows fetched -(defconstant +oci-attr-nested-prefetch-memory+ 14) ; memory limit for nested rows -(defconstant +oci-attr-char-count+ 15) ; this specifies the bind and define size in characters -(defconstant +oci-attr-pdscl+ 16) ; packed decimal scale -(defconstant +oci-attr-pdfmt+ 17) ; packed decimal format -(defconstant +oci-attr-param-count+ 18) ; number of column in the select list -(defconstant +oci-attr-rowid+ 19) ; the rowid -(defconstant +oci-attr-charset+ 20) ; the character set value -(defconstant +oci-attr-nchar+ 21) ; NCHAR type -(defconstant +oci-attr-username+ 22) ; username attribute -(defconstant +oci-attr-password+ 23) ; password attribute -(defconstant +oci-attr-stmt-type+ 24) ; statement type -(defconstant +oci-attr-internal-name+ 25) ; user friendly global name -(defconstant +oci-attr-external-name+ 26) ; the internal name for global txn -(defconstant +oci-attr-xid+ 27) ; XOPEN defined global transaction id -(defconstant +oci-attr-trans-lock+ 28) ; -(defconstant +oci-attr-trans-name+ 29) ; string to identify a global transaction -(defconstant +oci-attr-heapalloc+ 30) ; memory allocated on the heap -(defconstant +oci-attr-charset-id+ 31) ; Character Set ID -(defconstant +oci-attr-charset-form+ 32) ; Character Set Form -(defconstant +oci-attr-maxdata-size+ 33) ; Maximumsize of data on the server -(defconstant +oci-attr-cache-opt-size+ 34) ; object cache optimal size -(defconstant +oci-attr-cache-max-size+ 35) ; object cache maximum size percentage -(defconstant +oci-attr-pinoption+ 36) ; object cache default pin option -(defconstant +oci-attr-alloc-duration+ 37) ; object cache default allocation duration -(defconstant +oci-attr-pin-duration+ 38) ; object cache default pin duration -(defconstant +oci-attr-fdo+ 39) ; Format Descriptor object attribute -(defconstant +oci-attr-postprocessing-callback+ 40) ; Callback to process outbind data -(defconstant +oci-attr-postprocessing-context+ 41) ; Callback context to process outbind data -(defconstant +oci-attr-rows-returned+ 42) ; Number of rows returned in current iter - for Bind handles -(defconstant +oci-attr-focbk+ 43) ; Failover Callback attribute -(defconstant +oci-attr-in-v8-mode+ 44) ; is the server/service context in V8 mode -(defconstant +oci-attr-lobempty+ 45) ; empty lob ? -(defconstant +oci-attr-sesslang+ 46) ; session language handle - -;; AQ Attribute Types -;; Enqueue Options - -(defconstant +oci-attr-visibility+ 47) ; visibility -(defconstant +oci-attr-relative-msgid+ 48) ; relative message id -(defconstant +oci-attr-sequence-deviation+ 49) ; sequence deviation - -; - Dequeue Options - - ; consumer name -;#define OCI-ATTR-DEQ-MODE 50 -;(defconstant +OCI-ATTR-CONSUMER-NAME 50 + 51) ; dequeue mode -;#define OCI-ATTR-NAVIGATION 52 ; navigation -;#define OCI-ATTR-WAIT 53 ; wait -;#define OCI-ATTR-DEQ-MSGID 54 ; dequeue message id - -; - Message Properties - -(defconstant +OCI-ATTR-PRIORITY+ 55) ; priority -(defconstant +OCI-ATTR-DELAY+ 56) ; delay -(defconstant +OCI-ATTR-EXPIRATION+ 57) ; expiration -(defconstant +OCI-ATTR-CORRELATION+ 58) ; correlation id -(defconstant +OCI-ATTR-ATTEMPTS+ 59) ; # of attempts -(defconstant +OCI-ATTR-RECIPIENT-LIST+ 60) ; recipient list -(defconstant +OCI-ATTR-EXCEPTION-QUEUE+ 61) ; exception queue name -(defconstant +OCI-ATTR-ENQ-TIME+ 62) ; enqueue time (only OCIAttrGet) -(defconstant +OCI-ATTR-MSG-STATE+ 63) ; message state (only OCIAttrGet) - -;; AQ Agent -(defconstant +OCI-ATTR-AGENT-NAME+ 64) ; agent name -(defconstant +OCI-ATTR-AGENT-ADDRESS+ 65) ; agent address -(defconstant +OCI-ATTR-AGENT-PROTOCOL+ 66) ; agent protocol - -;- Server handle - -(defconstant +OCI-ATTR-NATIVE-FDES+ 67) ; native cncxn file desc - -;-Parameter Attribute Types- - -(defconstant +OCI-ATTR-UNK+ 101) ; unknown attribute -(defconstant +OCI-ATTR-NUM-COLS+ 102) ; number of columns -(defconstant +OCI-ATTR-LIST-COLUMNS+ 103) ; parameter of the column list -(defconstant +OCI-ATTR-RDBA+ 104) ; DBA of the segment header -(defconstant +OCI-ATTR-CLUSTERED+ 105) ; whether the table is clustered -(defconstant +OCI-ATTR-PARTITIONED+ 106) ; whether the table is partitioned -(defconstant +OCI-ATTR-INDEX-ONLY+ 107) ; whether the table is index only -(defconstant +OCI-ATTR-LIST-ARGUMENTS+ 108) ; parameter of the argument list -(defconstant +OCI-ATTR-LIST-SUBPROGRAMS+ 109) ; parameter of the subprogram list -(defconstant +OCI-ATTR-REF-TDO+ 110) ; REF to the type descriptor -(defconstant +OCI-ATTR-LINK+ 111) ; the database link name -(defconstant +OCI-ATTR-MIN+ 112) ; minimum value -(defconstant +OCI-ATTR-MAX+ 113) ; maximum value -(defconstant +OCI-ATTR-INCR+ 114) ; increment value -(defconstant +OCI-ATTR-CACHE+ 115) ; number of sequence numbers cached -(defconstant +OCI-ATTR-ORDER+ 116) ; whether the sequence is ordered -(defconstant +OCI-ATTR-HW-MARK+ 117) ; high-water mark -(defconstant +OCI-ATTR-TYPE-SCHEMA+ 118) ; type's schema name -(defconstant +OCI-ATTR-TIMESTAMP+ 119) ; timestamp of the object -(defconstant +OCI-ATTR-NUM-ATTRS+ 120) ; number of sttributes -(defconstant +OCI-ATTR-NUM-PARAMS+ 121) ; number of parameters -(defconstant +OCI-ATTR-OBJID+ 122) ; object id for a table or view -(defconstant +OCI-ATTR-PTYPE+ 123) ; type of info described by -(defconstant +OCI-ATTR-PARAM+ 124) ; parameter descriptor -(defconstant +OCI-ATTR-OVERLOAD-ID+ 125) ; overload ID for funcs and procs -(defconstant +OCI-ATTR-TABLESPACE+ 126) ; table name space -(defconstant +OCI-ATTR-TDO+ 127) ; TDO of a type -(defconstant +OCI-ATTR-PARSE-ERROR-OFFSET+ 128) ; Parse Error offset -;-Credential Types- -(defconstant +OCI-CRED-RDBMS+ 1) ; database username/password -(defconstant +OCI-CRED-EXT+ 2) ; externally provided credentials - -;; Error Return Values- - -(defconstant +oci-continue+ -24200) ; Continue with the body of the OCI function -(defconstant +oci-still-executing+ -3123) ; OCI would block error -(defconstant +oci-invalid-handle+ -2) ; maps to SQL-INVALID-HANDLE -(defconstant +oci-error+ -1) ; maps to SQL-ERROR -(defconstant +oci-success+ 0) ; maps to SQL-SUCCESS of SAG CLI -(defconstant +oci-success-with-info+ 1) ; maps to SQL-SUCCESS-WITH-INFO -(defconstant +oci-need-data+ 99) ; maps to SQL-NEED-DATA -(defconstant +oci-no-data+ 100) ; maps to SQL-NO-DATA - -;; Parsing Syntax Types- - -(defconstant +oci-ntv-syntax+ 1) ; Use what so ever is the native lang of server -(defconstant +oci-v7-syntax+ 2) ; V7 language -(defconstant +oci-v8-syntax+ 3) ; V8 language - -;-Scrollable Cursor Options- - -(defconstant +oci-fetch-next+ #x02) ; next row -(defconstant +oci-fetch-first+ #x04) ; first row of the result set -(defconstant +oci-fetch-last+ #x08) ; the last row of the result set -(defconstant +oci-fetch-prior+ #x10) ; the previous row relative to current -(defconstant +oci-fetch-absolute+ #x20) ; absolute offset from first -(defconstant +oci-fetch-relative+ #x40) ; offset relative to current - -;-Bind and Define Options- - -(defconstant +OCI-SB2-IND-PTR+ #x01) ; unused -(defconstant +OCI-DATA-AT-EXEC+ #x02) ; data at execute time -(defconstant +OCI-DYNAMIC-FETCH+ #x02) ; fetch dynamically -(defconstant +OCI-PIECEWISE+ #x04) ; piecewise DMLs or fetch -;- - -;-Execution Modes- -(defconstant +OCI-BATCH-MODE+ #x01) ; batch the oci statement for execution -(defconstant +OCI-EXACT-FETCH+ #x02) ; fetch the exact rows specified -(defconstant +OCI-KEEP-FETCH-STATE+ #x04) ; unused -(defconstant +OCI-SCROLLABLE-CURSOR+ #x08) ; cursor scrollable -(defconstant +OCI-DESCRIBE-ONLY+ #x10) ; only describe the statement -(defconstant +OCI-COMMIT-ON-SUCCESS+ #x20) ; commit, if successful execution -;- - -;-Authentication Modes- -(defconstant +OCI-MIGRATE+ #x0001) ; migratable auth context -(defconstant +OCI-SYSDBA+ #x0002) ; for SYSDBA authorization -(defconstant +OCI-SYSOPER+ #x0004) ; for SYSOPER authorization -(defconstant +OCI-PRELIM-AUTH+ #x0008) ; for preliminary authorization -;- - -;-Piece Information- -(defconstant +OCI-PARAM-IN+ #x01) ; in parameter -(defconstant +OCI-PARAM-OUT+ #x02) ; out parameter -;- - -;- Transaction Start Flags - -; NOTE: OCI-TRANS-JOIN and OCI-TRANS-NOMIGRATE not supported in 8.0.X -(defconstant +OCI-TRANS-NEW+ #x00000001) ; starts a new transaction branch -(defconstant +OCI-TRANS-JOIN+ #x00000002) ; join an existing transaction -(defconstant +OCI-TRANS-RESUME+ #x00000004) ; resume this transaction -(defconstant +OCI-TRANS-STARTMASK+ #x000000ff) - - -(defconstant +OCI-TRANS-READONLY+ #x00000100) ; starts a readonly transaction -(defconstant +OCI-TRANS-READWRITE+ #x00000200) ; starts a read-write transaction -(defconstant +OCI-TRANS-SERIALIZABLE+ #x00000400) - ; starts a serializable transaction -(defconstant +OCI-TRANS-ISOLMASK+ #x0000ff00) - -(defconstant +OCI-TRANS-LOOSE+ #x00010000) ; a loosely coupled branch -(defconstant +OCI-TRANS-TIGHT+ #x00020000) ; a tightly coupled branch -(defconstant +OCI-TRANS-TYPEMASK+ #x000f0000) ; - -(defconstant +OCI-TRANS-NOMIGRATE+ #x00100000) ; non migratable transaction - -;- - -;- Transaction End Flags - -(defconstant +OCI-TRANS-TWOPHASE+ #x01000000) ; use two phase commit -;- - -;; AQ Constants -;; NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE -;; The following constants must match the PL/SQL dbms-aq constants -;; NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE - -; - Visibility flags - -(defconstant +OCI-ENQ-IMMEDIATE+ 1) ; enqueue is an independent transaction -(defconstant +OCI-ENQ-ON-COMMIT+ 2) ; enqueue is part of current transaction - -; - Dequeue mode flags - -(defconstant +OCI-DEQ-BROWSE+ 1) ; read message without acquiring a lock -(defconstant +OCI-DEQ-LOCKED+ 2) ; read and obtain write lock on message -(defconstant +OCI-DEQ-REMOVE+ 3) ; read the message and delete it - -; - Dequeue navigation flags - -(defconstant +OCI-DEQ-FIRST-MSG+ 1) ; get first message at head of queue -(defconstant +OCI-DEQ-NEXT-MSG+ 3) ; next message that is available -(defconstant +OCI-DEQ-NEXT-TRANSACTION+ 2) ; get first message of next txn group - -; - Message states - -(defconstant +OCI-MSG-WAITING+ 1) ; the message delay has not yet completed -(defconstant +OCI-MSG-READY+ 0) ; the message is ready to be processed -(defconstant +OCI-MSG-PROCESSED+ 2) ; the message has been processed -(defconstant +OCI-MSG-EXPIRED+ 3) ; message has moved to exception queue - -; - Sequence deviation - -(defconstant +OCI-ENQ-BEFORE+ 2) ; enqueue message before another message -(defconstant +OCI-ENQ-TOP+ 3) ; enqueue message before all messages - -; - Visibility flags - -(defconstant +OCI-DEQ-IMMEDIATE+ 1) ; dequeue is an independent transaction -(defconstant +OCI-DEQ-ON-COMMIT+ 2) ; dequeue is part of current transaction - -; - Wait - -(defconstant +OCI-DEQ-WAIT-FOREVER+ -1) ; wait forever if no message available -(defconstant +OCI-DEQ-NO-WAIT+ 0) ; do not wait if no message is available - -; - Delay - -(defconstant +OCI-MSG-NO-DELAY+ 0) ; message is available immediately - -;; Expiration -(defconstant +OCI-MSG-NO-EXPIRATION+ -1) ; message will never expire - -;; Describe Handle Parameter Attributes -;; Attributes common to Columns and Stored Procs - -(defconstant +oci-attr-data-size+ 1) ; maximum size of the data -(defconstant +oci-attr-data-type+ 2) ; the sql type of the column/argument -(defconstant +oci-attr-disp-size+ 3) ; the display size -(defconstant +oci-attr-name+ 4) ; the name of the column/argument -(defconstant +oci-attr-precision+ 5) ; precision if number type -(defconstant +oci-attr-scale+ 6) ; scale if number type -(defconstant +oci-attr-is-null+ 7) ; is it null ? -(defconstant +oci-attr-type-name+ 8) - -;; name of the named data type or a package name for package private types - -(defconstant +OCI-ATTR-SCHEMA-NAME+ 9) ; the schema name -(defconstant +OCI-ATTR-SUB-NAME+ 10) ; type name if package private type -(defconstant +OCI-ATTR-POSITION+ 11) ; relative position of col/arg in the list of cols/args - -; complex object retrieval parameter attributes -(defconstant +OCI-ATTR-COMPLEXOBJECTCOMP-TYPE+ 50) ; -(defconstant +OCI-ATTR-COMPLEXOBJECTCOMP-TYPE-LEVEL+ 51) ; -(defconstant +OCI-ATTR-COMPLEXOBJECT-LEVEL+ 52) ; -(defconstant +OCI-ATTR-COMPLEXOBJECT-COLL-OUTOFLINE+ 53) ; - -; Only Columns -(defconstant +OCI-ATTR-DISP-NAME+ 100) ; the display name - -;; stored procs - -(defconstant +OCI-ATTR-OVERLOAD+ 210) ; is this position overloaded -(defconstant +OCI-ATTR-LEVEL+ 211) ; level for structured types -(defconstant +OCI-ATTR-HAS-DEFAULT+ 212) ; has a default value -(defconstant +OCI-ATTR-IOMODE+ 213) ; in, out inout -(defconstant +OCI-ATTR-RADIX+ 214) ; returns a radix -(defconstant +OCI-ATTR-NUM-ARGS+ 215) ; total number of arguments - -;; named type attributes - -(defconstant +oci-attr-typecode+ 216) ; lobject or collection -(defconstant +oci-attr-collection-typecode+ 217) ; varray or nested table -(defconstant +oci-attr-version+ 218) ; user assigned version -(defconstant +oci-attr-is-incomplete-type+ 219) ; is this an incomplete type -(defconstant +oci-attr-is-system-type+ 220) ; a system type -(defconstant +oci-attr-is-predefined-type+ 221) ; a predefined type -(defconstant +oci-attr-is-transient-type+ 222) ; a transient type -(defconstant +oci-attr-is-system-generated-type+ 223) ; system generated type -(defconstant +oci-attr-has-nested-table+ 224) ; contains nested table attr -(defconstant +oci-attr-has-lob+ 225) ; has a lob attribute -(defconstant +oci-attr-has-file+ 226) ; has a file attribute -(defconstant +oci-attr-collection-element+ 227) ; has a collection attribute -(defconstant +oci-attr-num-type-attrs+ 228) ; number of attribute types -(defconstant +oci-attr-list-type-attrs+ 229) ; list of type attributes -(defconstant +oci-attr-num-type-methods+ 230) ; number of type methods -(defconstant +oci-attr-list-type-methods+ 231) ; list of type methods -(defconstant +oci-attr-map-method+ 232) ; map method of type -(defconstant +oci-attr-order-method+ 233) ; order method of type - -; only collection element -(defconstant +OCI-ATTR-NUM-ELEMS+ 234) ; number of elements - -; only type methods -(defconstant +OCI-ATTR-ENCAPSULATION+ 235) ; encapsulation level -(defconstant +OCI-ATTR-IS-SELFISH+ 236) ; method selfish -(defconstant +OCI-ATTR-IS-VIRTUAL+ 237) ; virtual -(defconstant +OCI-ATTR-IS-INLINE+ 238) ; inline -(defconstant +OCI-ATTR-IS-CONSTANT+ 239) ; constant -(defconstant +OCI-ATTR-HAS-RESULT+ 240) ; has result -(defconstant +OCI-ATTR-IS-CONSTRUCTOR+ 241) ; constructor -(defconstant +OCI-ATTR-IS-DESTRUCTOR+ 242) ; destructor -(defconstant +OCI-ATTR-IS-OPERATOR+ 243) ; operator -(defconstant +OCI-ATTR-IS-MAP+ 244) ; a map method -(defconstant +OCI-ATTR-IS-ORDER+ 245) ; order method -(defconstant +OCI-ATTR-IS-RNDS+ 246) ; read no data state method -(defconstant +OCI-ATTR-IS-RNPS+ 247) ; read no process state -(defconstant +OCI-ATTR-IS-WNDS+ 248) ; write no data state method -(defconstant +OCI-ATTR-IS-WNPS+ 249) ; write no process state - -; describing public objects -(defconstant +OCI-ATTR-DESC-PUBLIC+ 250) ; public object -;- - -;-OCIPasswordChange- -(defconstant +OCI-AUTH+ #x08) ; Change the password but do not login - - -;-Other Constants- -(defconstant +OCI-MAX-FNS+ 100) ; max number of OCI Functions -(defconstant +OCI-SQLSTATE-SIZE+ 5) ; -(defconstant +OCI-ERROR-MAXMSG-SIZE+ 1024) ; max size of an error message -;; (defconstant +OCI-LOBMAXSIZE+ 4MAXVAL) ; maximum lob data size -(defconstant +OCI-ROWID-LEN+ 23) ; -;- - -;- Fail Over Events - -(defconstant +OCI-FO-END+ #x00000001) ; -(defconstant +OCI-FO-ABORT+ #x00000002) ; -(defconstant +OCI-FO-REAUTH+ #x00000004) ; -(defconstant +OCI-FO-BEGIN+ #x00000008) ; -(defconstant +OCI-FO-ERROR+ #x00000010) ; -;- - -;- Fail Over Types - -(defconstant +OCI-FO-NONE+ #x00000001) ; -(defconstant +OCI-FO-SESSION+ #x00000002) ; -(defconstant +OCI-FO-SELECT+ #x00000004) ; -(defconstant +OCI-FO-TXNAL+ #x00000008) ; -;- - -;-Function Codes- -(defconstant +OCI-FNCODE-INITIALIZE+ 1) ; OCIInitialize -(defconstant +OCI-FNCODE-HANDLEALLOC+ 2) ; OCIHandleAlloc -(defconstant +OCI-FNCODE-HANDLEFREE+ 3) ; OCIHandleFree -(defconstant +OCI-FNCODE-DESCRIPTORALLOC+ 4) ; OCIDescriptorAlloc -(defconstant +OCI-FNCODE-DESCRIPTORFREE+ 5) ; OCIDescriptorFree -(defconstant +OCI-FNCODE-ENVINIT+ 6) ; OCIEnvInit -(defconstant +OCI-FNCODE-SERVERATTACH+ 7) ; OCIServerAttach -(defconstant +OCI-FNCODE-SERVERDETACH+ 8) ; OCIServerDetach -; unused 9 -(defconstant +OCI-FNCODE-SESSIONBEGIN+ 10) ; OCISessionBegin -(defconstant +OCI-FNCODE-SESSIONEND+ 11) ; OCISessionEnd -(defconstant +OCI-FNCODE-PASSWORDCHANGE+ 12) ; OCIPasswordChange -(defconstant +OCI-FNCODE-STMTPREPARE+ 13) ; OCIStmtPrepare - ; unused 14- 16 -(defconstant +OCI-FNCODE-BINDDYNAMIC+ 17) ; OCIBindDynamic -(defconstant +OCI-FNCODE-BINDOBJECT+ 18) ; OCIBindObject - ; 19 unused -(defconstant +OCI-FNCODE-BINDARRAYOFSTRUCT+ 20) ; OCIBindArrayOfStruct -(defconstant +OCI-FNCODE-STMTEXECUTE+ 21) ; OCIStmtExecute - ; unused 22-24 -(defconstant +OCI-FNCODE-DEFINEOBJECT+ 25) ; OCIDefineObject -(defconstant +OCI-FNCODE-DEFINEDYNAMIC+ 26) ; OCIDefineDynamic -(defconstant +OCI-FNCODE-DEFINEARRAYOFSTRUCT+ 27) ; OCIDefineArrayOfStruct -(defconstant +OCI-FNCODE-STMTFETCH+ 28) ; OCIStmtFetch -(defconstant +OCI-FNCODE-STMTGETBIND+ 29) ; OCIStmtGetBindInfo - ; 30, 31 unused -(defconstant +OCI-FNCODE-DESCRIBEANY+ 32) ; OCIDescribeAny -(defconstant +OCI-FNCODE-TRANSSTART+ 33) ; OCITransStart -(defconstant +OCI-FNCODE-TRANSDETACH+ 34) ; OCITransDetach -(defconstant +OCI-FNCODE-TRANSCOMMIT+ 35) ; OCITransCommit - ; 36 unused -(defconstant +OCI-FNCODE-ERRORGET+ 37) ; OCIErrorGet -(defconstant +OCI-FNCODE-LOBOPENFILE+ 38) ; OCILobFileOpen -(defconstant +OCI-FNCODE-LOBCLOSEFILE+ 39) ; OCILobFileClose - ; 40 was LOBCREATEFILE, unused - ; 41 was OCILobFileDelete, unused -(defconstant +OCI-FNCODE-LOBCOPY+ 42) ; OCILobCopy -(defconstant +OCI-FNCODE-LOBAPPEND+ 43) ; OCILobAppend -(defconstant +OCI-FNCODE-LOBERASE+ 44) ; OCILobErase -(defconstant +OCI-FNCODE-LOBLENGTH+ 45) ; OCILobGetLength -(defconstant +OCI-FNCODE-LOBTRIM+ 46) ; OCILobTrim -(defconstant +OCI-FNCODE-LOBREAD+ 47) ; OCILobRead -(defconstant +OCI-FNCODE-LOBWRITE+ 48) ; OCILobWrite - ; 49 unused -(defconstant +OCI-FNCODE-SVCCTXBREAK+ 50) ; OCIBreak -(defconstant +OCI-FNCODE-SERVERVERSION+ 51) ; OCIServerVersion -; unused 52, 53 -(defconstant +OCI-FNCODE-ATTRGET+ 54) ; OCIAttrGet -(defconstant +OCI-FNCODE-ATTRSET+ 55) ; OCIAttrSet -(defconstant +OCI-FNCODE-PARAMSET+ 56) ; OCIParamSet -(defconstant +OCI-FNCODE-PARAMGET+ 57) ; OCIParamGet -(defconstant +OCI-FNCODE-STMTGETPIECEINFO+ 58) ; OCIStmtGetPieceInfo -(defconstant +OCI-FNCODE-LDATOSVCCTX+ 59) ; OCILdaToSvcCtx - ; 60 unused -(defconstant +OCI-FNCODE-STMTSETPIECEINFO+ 61) ; OCIStmtSetPieceInfo -(defconstant +OCI-FNCODE-TRANSFORGET+ 62) ; OCITransForget -(defconstant +OCI-FNCODE-TRANSPREPARE+ 63) ; OCITransPrepare -(defconstant +OCI-FNCODE-TRANSROLLBACK+ 64) ; OCITransRollback -(defconstant +OCI-FNCODE-DEFINEBYPOS+ 65) ; OCIDefineByPos -(defconstant +OCI-FNCODE-BINDBYPOS+ 66) ; OCIBindByPos -(defconstant +OCI-FNCODE-BINDBYNAME+ 67) ; OCIBindByName -(defconstant +OCI-FNCODE-LOBASSIGN+ 68) ; OCILobAssign -(defconstant +OCI-FNCODE-LOBISEQUAL+ 69) ; OCILobIsEqual -(defconstant +OCI-FNCODE-LOBISINIT+ 70) ; OCILobLocatorIsInit -; 71 was lob locator size in beta2 -(defconstant +OCI-FNCODE-LOBENABLEBUFFERING+ 71) ; OCILobEnableBuffering -(defconstant +OCI-FNCODE-LOBCHARSETID+ 72) ; OCILobCharSetID -(defconstant +OCI-FNCODE-LOBCHARSETFORM+ 73) ; OCILobCharSetForm -(defconstant +OCI-FNCODE-LOBFILESETNAME+ 74) ; OCILobFileSetName -(defconstant +OCI-FNCODE-LOBFILEGETNAME+ 75) ; OCILobFileGetName -(defconstant +OCI-FNCODE-LOGON+ 76) ; OCILogon -(defconstant +OCI-FNCODE-LOGOFF+ 77) ; OCILogoff -(defconstant +OCI-FNCODE-LOBDISABLEBUFFERING+ 78) ; OCILobDisableBuffering -(defconstant +OCI-FNCODE-LOBFLUSHBUFFER+ 79) ; OCILobFlushBuffer -(defconstant +OCI-FNCODE-LOBLOADFROMFILE+ 80) ; OCILobLoadFromFile - - -;- - -;- FILE open modes - -(defconstant +OCI-FILE-READONLY+ 1) ; readonly mode open for FILE types -;- - -;- LOB Buffering Flush Flags - -(defconstant +OCI-LOB-BUFFER-FREE+ 1) ; -(defconstant +OCI-LOB-BUFFER-NOFREE+ 2) ; -;- - -;- OCI Statement Types - - -(defconstant +oci-stmt-select+ 1) ; select statement -(defconstant +oci-stmt-update+ 2) ; update statement -(defconstant +oci-stmt-delete+ 3) ; delete statement -(defconstant +oci-stmt-insert+ 4) ; insert statement -(defconstant +oci-stmt-create+ 5) ; create statement -(defconstant +oci-stmt-drop+ 6) ; drop statement -(defconstant +oci-stmt-alter+ 7) ; alter statement -(defconstant +oci-stmt-begin+ 8) ; begin ... (pl/sql statement) -(defconstant +oci-stmt-declare+ 9) ; declare .. (pl/sql statement ) -;- - -;- OCI Parameter Types - -(defconstant +OCI-PTYPE-UNK+ 0) ; unknown -(defconstant +OCI-PTYPE-TABLE+ 1) ; table -(defconstant +OCI-PTYPE-VIEW+ 2) ; view -(defconstant +OCI-PTYPE-PROC+ 3) ; procedure -(defconstant +OCI-PTYPE-FUNC+ 4) ; function -(defconstant +OCI-PTYPE-PKG+ 5) ; package -(defconstant +OCI-PTYPE-TYPE+ 6) ; user-defined type -(defconstant +OCI-PTYPE-SYN+ 7) ; synonym -(defconstant +OCI-PTYPE-SEQ+ 8) ; sequence -(defconstant +OCI-PTYPE-COL+ 9) ; column -(defconstant +OCI-PTYPE-ARG+ 10) ; argument -(defconstant +OCI-PTYPE-LIST+ 11) ; list -(defconstant +OCI-PTYPE-TYPE-ATTR+ 12) ; user-defined type's attribute -(defconstant +OCI-PTYPE-TYPE-COLL+ 13) ; collection type's element -(defconstant +OCI-PTYPE-TYPE-METHOD+ 14) ; user-defined type's method -(defconstant +OCI-PTYPE-TYPE-ARG+ 15) ; user-defined type method's argument -(defconstant +OCI-PTYPE-TYPE-RESULT+ 16) ; user-defined type method's result -;- - -;- OCI List Types - -(defconstant +OCI-LTYPE-UNK+ 0) ; unknown -(defconstant +OCI-LTYPE-COLUMN+ 1) ; column list -(defconstant +OCI-LTYPE-ARG-PROC+ 2) ; procedure argument list -(defconstant +OCI-LTYPE-ARG-FUNC+ 3) ; function argument list -(defconstant +OCI-LTYPE-SUBPRG+ 4) ; subprogram list -(defconstant +OCI-LTYPE-TYPE-ATTR+ 5) ; type attribute -(defconstant +OCI-LTYPE-TYPE-METHOD+ 6) ; type method -(defconstant +OCI-LTYPE-TYPE-ARG-PROC+ 7) ; type method w/o result argument list -(defconstant +OCI-LTYPE-TYPE-ARG-FUNC+ 8) ; type method w/result argument list - -;; typecodes - diff --git a/db-oracle/oracle-constants.lisp b/db-oracle/oracle-constants.lisp new file mode 100644 index 0000000..a7c3cfa --- /dev/null +++ b/db-oracle/oracle-constants.lisp @@ -0,0 +1,530 @@ +;;; -*- Mode: Lisp -*- +;;; $Id: oracle-constants.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $ + +(in-package :clsql-oracle) + +(defconstant +oci-default+ #x00) ; default value for parameters and attributes +(defconstant +oci-threaded+ #x01) ; application is in threaded environment +(defconstant +oci-object+ #x02) ; the application is in object environment +(defconstant +oci-non-blocking+ #x04) ; non blocking mode of operation +(defconstant +oci-env-no-mutex+ #x08) ; the environment handle will not be protected by a mutex internally + +;; Handle types + +(defconstant +oci-htype-env+ 1) ; environment handle +(defconstant +oci-htype-error+ 2) ; error handle +(defconstant +oci-htype-svcctx+ 3) ; service handle +(defconstant +oci-htype-stmt+ 4) ; statement handle +(defconstant +oci-htype-bind+ 5) ; bind handle +(defconstant +oci-htype-define+ 6) ; define handle +(defconstant +oci-htype-describe+ 7) ; describe handle +(defconstant +oci-htype-server+ 8) ; server handle +(defconstant +oci-htype-session+ 9) ; authentication handle +(defconstant +oci-htype-trans+ 10) ; transaction handle +(defconstant +oci-htype-complexobject+ 11) ; complex object retrieval handle +(defconstant +oci-htype-security+ 12) ; security handle + +;; Descriptor types + +(defconstant +oci-dtype-lob+ 50) ; lob locator +(defconstant +oci-dtype-snap+ 51) ; snapshot +(defconstant +oci-dtype-rset+ 52) ; result set +(defconstant +oci-dtype-param+ 53) ; parameter descriptor obtained from ocigparm +(defconstant +oci-dtype-rowid+ 54) ; rowid +(defconstant +oci-dtype-complexobjectcomp+ 55) ; complex object retrieval descriptor +(defconstant +oci-dtype-file+ 56) ; File Lob locator +(defconstant +oci-dtype-aqenq-options+ 57) ; enqueue options +(defconstant +oci-dtype-aqdeq-options+ 58) ; dequeue options +(defconstant +oci-dtype-aqmsg-properties+ 59) ; message properties +(defconstant +oci-dtype-aqagent+ 60) ; aq agent + +;; Objectr pointer types + +(defconstant +oci-otype-name+ 1) ; object name +(defconstant +oci-otype-ref+ 2) ; REF to TDO +(defconstant +oci-otype-ptr+ 3) ; PTR to TDO + +;; Attribute types + +(defconstant +oci-attr-fncode+ 1) ; the OCI function code +(defconstant +oci-attr-object+ 2) ; is the environment initialized in object mode +(defconstant +oci-attr-nonblocking-mode+ 3) ; non blocking mode +(defconstant +oci-attr-sqlcode+ 4) ; the SQL verb +(defconstant +oci-attr-env+ 5) ; the environment handle +(defconstant +oci-attr-server+ 6) ; the server handle +(defconstant +oci-attr-session+ 7) ; the user session handle +(defconstant +oci-attr-trans+ 8) ; the transaction handle +(defconstant +oci-attr-row-count+ 9) ; the rows processed so far +(defconstant +oci-attr-sqlfncode+ 10) ; the SQL verb of the statement +(defconstant +oci-attr-prefetch-rows+ 11) ; sets the number of rows to prefetch +(defconstant +oci-attr-nested-prefetch-rows+ 12) ; the prefetch rows of nested table +(defconstant +oci-attr-prefetch-memory+ 13) ; memory limit for rows fetched +(defconstant +oci-attr-nested-prefetch-memory+ 14) ; memory limit for nested rows +(defconstant +oci-attr-char-count+ 15) ; this specifies the bind and define size in characters +(defconstant +oci-attr-pdscl+ 16) ; packed decimal scale +(defconstant +oci-attr-pdfmt+ 17) ; packed decimal format +(defconstant +oci-attr-param-count+ 18) ; number of column in the select list +(defconstant +oci-attr-rowid+ 19) ; the rowid +(defconstant +oci-attr-charset+ 20) ; the character set value +(defconstant +oci-attr-nchar+ 21) ; NCHAR type +(defconstant +oci-attr-username+ 22) ; username attribute +(defconstant +oci-attr-password+ 23) ; password attribute +(defconstant +oci-attr-stmt-type+ 24) ; statement type +(defconstant +oci-attr-internal-name+ 25) ; user friendly global name +(defconstant +oci-attr-external-name+ 26) ; the internal name for global txn +(defconstant +oci-attr-xid+ 27) ; XOPEN defined global transaction id +(defconstant +oci-attr-trans-lock+ 28) ; +(defconstant +oci-attr-trans-name+ 29) ; string to identify a global transaction +(defconstant +oci-attr-heapalloc+ 30) ; memory allocated on the heap +(defconstant +oci-attr-charset-id+ 31) ; Character Set ID +(defconstant +oci-attr-charset-form+ 32) ; Character Set Form +(defconstant +oci-attr-maxdata-size+ 33) ; Maximumsize of data on the server +(defconstant +oci-attr-cache-opt-size+ 34) ; object cache optimal size +(defconstant +oci-attr-cache-max-size+ 35) ; object cache maximum size percentage +(defconstant +oci-attr-pinoption+ 36) ; object cache default pin option +(defconstant +oci-attr-alloc-duration+ 37) ; object cache default allocation duration +(defconstant +oci-attr-pin-duration+ 38) ; object cache default pin duration +(defconstant +oci-attr-fdo+ 39) ; Format Descriptor object attribute +(defconstant +oci-attr-postprocessing-callback+ 40) ; Callback to process outbind data +(defconstant +oci-attr-postprocessing-context+ 41) ; Callback context to process outbind data +(defconstant +oci-attr-rows-returned+ 42) ; Number of rows returned in current iter - for Bind handles +(defconstant +oci-attr-focbk+ 43) ; Failover Callback attribute +(defconstant +oci-attr-in-v8-mode+ 44) ; is the server/service context in V8 mode +(defconstant +oci-attr-lobempty+ 45) ; empty lob ? +(defconstant +oci-attr-sesslang+ 46) ; session language handle + +;; AQ Attribute Types +;; Enqueue Options + +(defconstant +oci-attr-visibility+ 47) ; visibility +(defconstant +oci-attr-relative-msgid+ 48) ; relative message id +(defconstant +oci-attr-sequence-deviation+ 49) ; sequence deviation + +; - Dequeue Options - + ; consumer name +;#define OCI-ATTR-DEQ-MODE 50 +;(defconstant +OCI-ATTR-CONSUMER-NAME 50 + 51) ; dequeue mode +;#define OCI-ATTR-NAVIGATION 52 ; navigation +;#define OCI-ATTR-WAIT 53 ; wait +;#define OCI-ATTR-DEQ-MSGID 54 ; dequeue message id + +; - Message Properties - +(defconstant +OCI-ATTR-PRIORITY+ 55) ; priority +(defconstant +OCI-ATTR-DELAY+ 56) ; delay +(defconstant +OCI-ATTR-EXPIRATION+ 57) ; expiration +(defconstant +OCI-ATTR-CORRELATION+ 58) ; correlation id +(defconstant +OCI-ATTR-ATTEMPTS+ 59) ; # of attempts +(defconstant +OCI-ATTR-RECIPIENT-LIST+ 60) ; recipient list +(defconstant +OCI-ATTR-EXCEPTION-QUEUE+ 61) ; exception queue name +(defconstant +OCI-ATTR-ENQ-TIME+ 62) ; enqueue time (only OCIAttrGet) +(defconstant +OCI-ATTR-MSG-STATE+ 63) ; message state (only OCIAttrGet) + +;; AQ Agent +(defconstant +OCI-ATTR-AGENT-NAME+ 64) ; agent name +(defconstant +OCI-ATTR-AGENT-ADDRESS+ 65) ; agent address +(defconstant +OCI-ATTR-AGENT-PROTOCOL+ 66) ; agent protocol + +;- Server handle - +(defconstant +OCI-ATTR-NATIVE-FDES+ 67) ; native cncxn file desc + +;-Parameter Attribute Types- + +(defconstant +OCI-ATTR-UNK+ 101) ; unknown attribute +(defconstant +OCI-ATTR-NUM-COLS+ 102) ; number of columns +(defconstant +OCI-ATTR-LIST-COLUMNS+ 103) ; parameter of the column list +(defconstant +OCI-ATTR-RDBA+ 104) ; DBA of the segment header +(defconstant +OCI-ATTR-CLUSTERED+ 105) ; whether the table is clustered +(defconstant +OCI-ATTR-PARTITIONED+ 106) ; whether the table is partitioned +(defconstant +OCI-ATTR-INDEX-ONLY+ 107) ; whether the table is index only +(defconstant +OCI-ATTR-LIST-ARGUMENTS+ 108) ; parameter of the argument list +(defconstant +OCI-ATTR-LIST-SUBPROGRAMS+ 109) ; parameter of the subprogram list +(defconstant +OCI-ATTR-REF-TDO+ 110) ; REF to the type descriptor +(defconstant +OCI-ATTR-LINK+ 111) ; the database link name +(defconstant +OCI-ATTR-MIN+ 112) ; minimum value +(defconstant +OCI-ATTR-MAX+ 113) ; maximum value +(defconstant +OCI-ATTR-INCR+ 114) ; increment value +(defconstant +OCI-ATTR-CACHE+ 115) ; number of sequence numbers cached +(defconstant +OCI-ATTR-ORDER+ 116) ; whether the sequence is ordered +(defconstant +OCI-ATTR-HW-MARK+ 117) ; high-water mark +(defconstant +OCI-ATTR-TYPE-SCHEMA+ 118) ; type's schema name +(defconstant +OCI-ATTR-TIMESTAMP+ 119) ; timestamp of the object +(defconstant +OCI-ATTR-NUM-ATTRS+ 120) ; number of sttributes +(defconstant +OCI-ATTR-NUM-PARAMS+ 121) ; number of parameters +(defconstant +OCI-ATTR-OBJID+ 122) ; object id for a table or view +(defconstant +OCI-ATTR-PTYPE+ 123) ; type of info described by +(defconstant +OCI-ATTR-PARAM+ 124) ; parameter descriptor +(defconstant +OCI-ATTR-OVERLOAD-ID+ 125) ; overload ID for funcs and procs +(defconstant +OCI-ATTR-TABLESPACE+ 126) ; table name space +(defconstant +OCI-ATTR-TDO+ 127) ; TDO of a type +(defconstant +OCI-ATTR-PARSE-ERROR-OFFSET+ 128) ; Parse Error offset +;-Credential Types- +(defconstant +OCI-CRED-RDBMS+ 1) ; database username/password +(defconstant +OCI-CRED-EXT+ 2) ; externally provided credentials + +;; Error Return Values- + +(defconstant +oci-continue+ -24200) ; Continue with the body of the OCI function +(defconstant +oci-still-executing+ -3123) ; OCI would block error +(defconstant +oci-invalid-handle+ -2) ; maps to SQL-INVALID-HANDLE +(defconstant +oci-error+ -1) ; maps to SQL-ERROR +(defconstant +oci-success+ 0) ; maps to SQL-SUCCESS of SAG CLI +(defconstant +oci-success-with-info+ 1) ; maps to SQL-SUCCESS-WITH-INFO +(defconstant +oci-need-data+ 99) ; maps to SQL-NEED-DATA +(defconstant +oci-no-data+ 100) ; maps to SQL-NO-DATA + +;; Parsing Syntax Types- + +(defconstant +oci-ntv-syntax+ 1) ; Use what so ever is the native lang of server +(defconstant +oci-v7-syntax+ 2) ; V7 language +(defconstant +oci-v8-syntax+ 3) ; V8 language + +;-Scrollable Cursor Options- + +(defconstant +oci-fetch-next+ #x02) ; next row +(defconstant +oci-fetch-first+ #x04) ; first row of the result set +(defconstant +oci-fetch-last+ #x08) ; the last row of the result set +(defconstant +oci-fetch-prior+ #x10) ; the previous row relative to current +(defconstant +oci-fetch-absolute+ #x20) ; absolute offset from first +(defconstant +oci-fetch-relative+ #x40) ; offset relative to current + +;-Bind and Define Options- + +(defconstant +OCI-SB2-IND-PTR+ #x01) ; unused +(defconstant +OCI-DATA-AT-EXEC+ #x02) ; data at execute time +(defconstant +OCI-DYNAMIC-FETCH+ #x02) ; fetch dynamically +(defconstant +OCI-PIECEWISE+ #x04) ; piecewise DMLs or fetch +;- + +;-Execution Modes- +(defconstant +OCI-BATCH-MODE+ #x01) ; batch the oci statement for execution +(defconstant +OCI-EXACT-FETCH+ #x02) ; fetch the exact rows specified +(defconstant +OCI-KEEP-FETCH-STATE+ #x04) ; unused +(defconstant +OCI-SCROLLABLE-CURSOR+ #x08) ; cursor scrollable +(defconstant +OCI-DESCRIBE-ONLY+ #x10) ; only describe the statement +(defconstant +OCI-COMMIT-ON-SUCCESS+ #x20) ; commit, if successful execution +;- + +;-Authentication Modes- +(defconstant +OCI-MIGRATE+ #x0001) ; migratable auth context +(defconstant +OCI-SYSDBA+ #x0002) ; for SYSDBA authorization +(defconstant +OCI-SYSOPER+ #x0004) ; for SYSOPER authorization +(defconstant +OCI-PRELIM-AUTH+ #x0008) ; for preliminary authorization +;- + +;-Piece Information- +(defconstant +OCI-PARAM-IN+ #x01) ; in parameter +(defconstant +OCI-PARAM-OUT+ #x02) ; out parameter +;- + +;- Transaction Start Flags - +; NOTE: OCI-TRANS-JOIN and OCI-TRANS-NOMIGRATE not supported in 8.0.X +(defconstant +OCI-TRANS-NEW+ #x00000001) ; starts a new transaction branch +(defconstant +OCI-TRANS-JOIN+ #x00000002) ; join an existing transaction +(defconstant +OCI-TRANS-RESUME+ #x00000004) ; resume this transaction +(defconstant +OCI-TRANS-STARTMASK+ #x000000ff) + + +(defconstant +OCI-TRANS-READONLY+ #x00000100) ; starts a readonly transaction +(defconstant +OCI-TRANS-READWRITE+ #x00000200) ; starts a read-write transaction +(defconstant +OCI-TRANS-SERIALIZABLE+ #x00000400) + ; starts a serializable transaction +(defconstant +OCI-TRANS-ISOLMASK+ #x0000ff00) + +(defconstant +OCI-TRANS-LOOSE+ #x00010000) ; a loosely coupled branch +(defconstant +OCI-TRANS-TIGHT+ #x00020000) ; a tightly coupled branch +(defconstant +OCI-TRANS-TYPEMASK+ #x000f0000) ; + +(defconstant +OCI-TRANS-NOMIGRATE+ #x00100000) ; non migratable transaction + +;- + +;- Transaction End Flags - +(defconstant +OCI-TRANS-TWOPHASE+ #x01000000) ; use two phase commit +;- + +;; AQ Constants +;; NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE +;; The following constants must match the PL/SQL dbms-aq constants +;; NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE + +; - Visibility flags - +(defconstant +OCI-ENQ-IMMEDIATE+ 1) ; enqueue is an independent transaction +(defconstant +OCI-ENQ-ON-COMMIT+ 2) ; enqueue is part of current transaction + +; - Dequeue mode flags - +(defconstant +OCI-DEQ-BROWSE+ 1) ; read message without acquiring a lock +(defconstant +OCI-DEQ-LOCKED+ 2) ; read and obtain write lock on message +(defconstant +OCI-DEQ-REMOVE+ 3) ; read the message and delete it + +; - Dequeue navigation flags - +(defconstant +OCI-DEQ-FIRST-MSG+ 1) ; get first message at head of queue +(defconstant +OCI-DEQ-NEXT-MSG+ 3) ; next message that is available +(defconstant +OCI-DEQ-NEXT-TRANSACTION+ 2) ; get first message of next txn group + +; - Message states - +(defconstant +OCI-MSG-WAITING+ 1) ; the message delay has not yet completed +(defconstant +OCI-MSG-READY+ 0) ; the message is ready to be processed +(defconstant +OCI-MSG-PROCESSED+ 2) ; the message has been processed +(defconstant +OCI-MSG-EXPIRED+ 3) ; message has moved to exception queue + +; - Sequence deviation - +(defconstant +OCI-ENQ-BEFORE+ 2) ; enqueue message before another message +(defconstant +OCI-ENQ-TOP+ 3) ; enqueue message before all messages + +; - Visibility flags - +(defconstant +OCI-DEQ-IMMEDIATE+ 1) ; dequeue is an independent transaction +(defconstant +OCI-DEQ-ON-COMMIT+ 2) ; dequeue is part of current transaction + +; - Wait - +(defconstant +OCI-DEQ-WAIT-FOREVER+ -1) ; wait forever if no message available +(defconstant +OCI-DEQ-NO-WAIT+ 0) ; do not wait if no message is available + +; - Delay - +(defconstant +OCI-MSG-NO-DELAY+ 0) ; message is available immediately + +;; Expiration +(defconstant +OCI-MSG-NO-EXPIRATION+ -1) ; message will never expire + +;; Describe Handle Parameter Attributes +;; Attributes common to Columns and Stored Procs + +(defconstant +oci-attr-data-size+ 1) ; maximum size of the data +(defconstant +oci-attr-data-type+ 2) ; the sql type of the column/argument +(defconstant +oci-attr-disp-size+ 3) ; the display size +(defconstant +oci-attr-name+ 4) ; the name of the column/argument +(defconstant +oci-attr-precision+ 5) ; precision if number type +(defconstant +oci-attr-scale+ 6) ; scale if number type +(defconstant +oci-attr-is-null+ 7) ; is it null ? +(defconstant +oci-attr-type-name+ 8) + +;; name of the named data type or a package name for package private types + +(defconstant +OCI-ATTR-SCHEMA-NAME+ 9) ; the schema name +(defconstant +OCI-ATTR-SUB-NAME+ 10) ; type name if package private type +(defconstant +OCI-ATTR-POSITION+ 11) ; relative position of col/arg in the list of cols/args + +; complex object retrieval parameter attributes +(defconstant +OCI-ATTR-COMPLEXOBJECTCOMP-TYPE+ 50) ; +(defconstant +OCI-ATTR-COMPLEXOBJECTCOMP-TYPE-LEVEL+ 51) ; +(defconstant +OCI-ATTR-COMPLEXOBJECT-LEVEL+ 52) ; +(defconstant +OCI-ATTR-COMPLEXOBJECT-COLL-OUTOFLINE+ 53) ; + +; Only Columns +(defconstant +OCI-ATTR-DISP-NAME+ 100) ; the display name + +;; stored procs + +(defconstant +OCI-ATTR-OVERLOAD+ 210) ; is this position overloaded +(defconstant +OCI-ATTR-LEVEL+ 211) ; level for structured types +(defconstant +OCI-ATTR-HAS-DEFAULT+ 212) ; has a default value +(defconstant +OCI-ATTR-IOMODE+ 213) ; in, out inout +(defconstant +OCI-ATTR-RADIX+ 214) ; returns a radix +(defconstant +OCI-ATTR-NUM-ARGS+ 215) ; total number of arguments + +;; named type attributes + +(defconstant +oci-attr-typecode+ 216) ; lobject or collection +(defconstant +oci-attr-collection-typecode+ 217) ; varray or nested table +(defconstant +oci-attr-version+ 218) ; user assigned version +(defconstant +oci-attr-is-incomplete-type+ 219) ; is this an incomplete type +(defconstant +oci-attr-is-system-type+ 220) ; a system type +(defconstant +oci-attr-is-predefined-type+ 221) ; a predefined type +(defconstant +oci-attr-is-transient-type+ 222) ; a transient type +(defconstant +oci-attr-is-system-generated-type+ 223) ; system generated type +(defconstant +oci-attr-has-nested-table+ 224) ; contains nested table attr +(defconstant +oci-attr-has-lob+ 225) ; has a lob attribute +(defconstant +oci-attr-has-file+ 226) ; has a file attribute +(defconstant +oci-attr-collection-element+ 227) ; has a collection attribute +(defconstant +oci-attr-num-type-attrs+ 228) ; number of attribute types +(defconstant +oci-attr-list-type-attrs+ 229) ; list of type attributes +(defconstant +oci-attr-num-type-methods+ 230) ; number of type methods +(defconstant +oci-attr-list-type-methods+ 231) ; list of type methods +(defconstant +oci-attr-map-method+ 232) ; map method of type +(defconstant +oci-attr-order-method+ 233) ; order method of type + +; only collection element +(defconstant +OCI-ATTR-NUM-ELEMS+ 234) ; number of elements + +; only type methods +(defconstant +OCI-ATTR-ENCAPSULATION+ 235) ; encapsulation level +(defconstant +OCI-ATTR-IS-SELFISH+ 236) ; method selfish +(defconstant +OCI-ATTR-IS-VIRTUAL+ 237) ; virtual +(defconstant +OCI-ATTR-IS-INLINE+ 238) ; inline +(defconstant +OCI-ATTR-IS-CONSTANT+ 239) ; constant +(defconstant +OCI-ATTR-HAS-RESULT+ 240) ; has result +(defconstant +OCI-ATTR-IS-CONSTRUCTOR+ 241) ; constructor +(defconstant +OCI-ATTR-IS-DESTRUCTOR+ 242) ; destructor +(defconstant +OCI-ATTR-IS-OPERATOR+ 243) ; operator +(defconstant +OCI-ATTR-IS-MAP+ 244) ; a map method +(defconstant +OCI-ATTR-IS-ORDER+ 245) ; order method +(defconstant +OCI-ATTR-IS-RNDS+ 246) ; read no data state method +(defconstant +OCI-ATTR-IS-RNPS+ 247) ; read no process state +(defconstant +OCI-ATTR-IS-WNDS+ 248) ; write no data state method +(defconstant +OCI-ATTR-IS-WNPS+ 249) ; write no process state + +; describing public objects +(defconstant +OCI-ATTR-DESC-PUBLIC+ 250) ; public object +;- + +;-OCIPasswordChange- +(defconstant +OCI-AUTH+ #x08) ; Change the password but do not login + + +;-Other Constants- +(defconstant +OCI-MAX-FNS+ 100) ; max number of OCI Functions +(defconstant +OCI-SQLSTATE-SIZE+ 5) ; +(defconstant +OCI-ERROR-MAXMSG-SIZE+ 1024) ; max size of an error message +;; (defconstant +OCI-LOBMAXSIZE+ 4MAXVAL) ; maximum lob data size +(defconstant +OCI-ROWID-LEN+ 23) ; +;- + +;- Fail Over Events - +(defconstant +OCI-FO-END+ #x00000001) ; +(defconstant +OCI-FO-ABORT+ #x00000002) ; +(defconstant +OCI-FO-REAUTH+ #x00000004) ; +(defconstant +OCI-FO-BEGIN+ #x00000008) ; +(defconstant +OCI-FO-ERROR+ #x00000010) ; +;- + +;- Fail Over Types - +(defconstant +OCI-FO-NONE+ #x00000001) ; +(defconstant +OCI-FO-SESSION+ #x00000002) ; +(defconstant +OCI-FO-SELECT+ #x00000004) ; +(defconstant +OCI-FO-TXNAL+ #x00000008) ; +;- + +;-Function Codes- +(defconstant +OCI-FNCODE-INITIALIZE+ 1) ; OCIInitialize +(defconstant +OCI-FNCODE-HANDLEALLOC+ 2) ; OCIHandleAlloc +(defconstant +OCI-FNCODE-HANDLEFREE+ 3) ; OCIHandleFree +(defconstant +OCI-FNCODE-DESCRIPTORALLOC+ 4) ; OCIDescriptorAlloc +(defconstant +OCI-FNCODE-DESCRIPTORFREE+ 5) ; OCIDescriptorFree +(defconstant +OCI-FNCODE-ENVINIT+ 6) ; OCIEnvInit +(defconstant +OCI-FNCODE-SERVERATTACH+ 7) ; OCIServerAttach +(defconstant +OCI-FNCODE-SERVERDETACH+ 8) ; OCIServerDetach +; unused 9 +(defconstant +OCI-FNCODE-SESSIONBEGIN+ 10) ; OCISessionBegin +(defconstant +OCI-FNCODE-SESSIONEND+ 11) ; OCISessionEnd +(defconstant +OCI-FNCODE-PASSWORDCHANGE+ 12) ; OCIPasswordChange +(defconstant +OCI-FNCODE-STMTPREPARE+ 13) ; OCIStmtPrepare + ; unused 14- 16 +(defconstant +OCI-FNCODE-BINDDYNAMIC+ 17) ; OCIBindDynamic +(defconstant +OCI-FNCODE-BINDOBJECT+ 18) ; OCIBindObject + ; 19 unused +(defconstant +OCI-FNCODE-BINDARRAYOFSTRUCT+ 20) ; OCIBindArrayOfStruct +(defconstant +OCI-FNCODE-STMTEXECUTE+ 21) ; OCIStmtExecute + ; unused 22-24 +(defconstant +OCI-FNCODE-DEFINEOBJECT+ 25) ; OCIDefineObject +(defconstant +OCI-FNCODE-DEFINEDYNAMIC+ 26) ; OCIDefineDynamic +(defconstant +OCI-FNCODE-DEFINEARRAYOFSTRUCT+ 27) ; OCIDefineArrayOfStruct +(defconstant +OCI-FNCODE-STMTFETCH+ 28) ; OCIStmtFetch +(defconstant +OCI-FNCODE-STMTGETBIND+ 29) ; OCIStmtGetBindInfo + ; 30, 31 unused +(defconstant +OCI-FNCODE-DESCRIBEANY+ 32) ; OCIDescribeAny +(defconstant +OCI-FNCODE-TRANSSTART+ 33) ; OCITransStart +(defconstant +OCI-FNCODE-TRANSDETACH+ 34) ; OCITransDetach +(defconstant +OCI-FNCODE-TRANSCOMMIT+ 35) ; OCITransCommit + ; 36 unused +(defconstant +OCI-FNCODE-ERRORGET+ 37) ; OCIErrorGet +(defconstant +OCI-FNCODE-LOBOPENFILE+ 38) ; OCILobFileOpen +(defconstant +OCI-FNCODE-LOBCLOSEFILE+ 39) ; OCILobFileClose + ; 40 was LOBCREATEFILE, unused + ; 41 was OCILobFileDelete, unused +(defconstant +OCI-FNCODE-LOBCOPY+ 42) ; OCILobCopy +(defconstant +OCI-FNCODE-LOBAPPEND+ 43) ; OCILobAppend +(defconstant +OCI-FNCODE-LOBERASE+ 44) ; OCILobErase +(defconstant +OCI-FNCODE-LOBLENGTH+ 45) ; OCILobGetLength +(defconstant +OCI-FNCODE-LOBTRIM+ 46) ; OCILobTrim +(defconstant +OCI-FNCODE-LOBREAD+ 47) ; OCILobRead +(defconstant +OCI-FNCODE-LOBWRITE+ 48) ; OCILobWrite + ; 49 unused +(defconstant +OCI-FNCODE-SVCCTXBREAK+ 50) ; OCIBreak +(defconstant +OCI-FNCODE-SERVERVERSION+ 51) ; OCIServerVersion +; unused 52, 53 +(defconstant +OCI-FNCODE-ATTRGET+ 54) ; OCIAttrGet +(defconstant +OCI-FNCODE-ATTRSET+ 55) ; OCIAttrSet +(defconstant +OCI-FNCODE-PARAMSET+ 56) ; OCIParamSet +(defconstant +OCI-FNCODE-PARAMGET+ 57) ; OCIParamGet +(defconstant +OCI-FNCODE-STMTGETPIECEINFO+ 58) ; OCIStmtGetPieceInfo +(defconstant +OCI-FNCODE-LDATOSVCCTX+ 59) ; OCILdaToSvcCtx + ; 60 unused +(defconstant +OCI-FNCODE-STMTSETPIECEINFO+ 61) ; OCIStmtSetPieceInfo +(defconstant +OCI-FNCODE-TRANSFORGET+ 62) ; OCITransForget +(defconstant +OCI-FNCODE-TRANSPREPARE+ 63) ; OCITransPrepare +(defconstant +OCI-FNCODE-TRANSROLLBACK+ 64) ; OCITransRollback +(defconstant +OCI-FNCODE-DEFINEBYPOS+ 65) ; OCIDefineByPos +(defconstant +OCI-FNCODE-BINDBYPOS+ 66) ; OCIBindByPos +(defconstant +OCI-FNCODE-BINDBYNAME+ 67) ; OCIBindByName +(defconstant +OCI-FNCODE-LOBASSIGN+ 68) ; OCILobAssign +(defconstant +OCI-FNCODE-LOBISEQUAL+ 69) ; OCILobIsEqual +(defconstant +OCI-FNCODE-LOBISINIT+ 70) ; OCILobLocatorIsInit +; 71 was lob locator size in beta2 +(defconstant +OCI-FNCODE-LOBENABLEBUFFERING+ 71) ; OCILobEnableBuffering +(defconstant +OCI-FNCODE-LOBCHARSETID+ 72) ; OCILobCharSetID +(defconstant +OCI-FNCODE-LOBCHARSETFORM+ 73) ; OCILobCharSetForm +(defconstant +OCI-FNCODE-LOBFILESETNAME+ 74) ; OCILobFileSetName +(defconstant +OCI-FNCODE-LOBFILEGETNAME+ 75) ; OCILobFileGetName +(defconstant +OCI-FNCODE-LOGON+ 76) ; OCILogon +(defconstant +OCI-FNCODE-LOGOFF+ 77) ; OCILogoff +(defconstant +OCI-FNCODE-LOBDISABLEBUFFERING+ 78) ; OCILobDisableBuffering +(defconstant +OCI-FNCODE-LOBFLUSHBUFFER+ 79) ; OCILobFlushBuffer +(defconstant +OCI-FNCODE-LOBLOADFROMFILE+ 80) ; OCILobLoadFromFile + + +;- + +;- FILE open modes - +(defconstant +OCI-FILE-READONLY+ 1) ; readonly mode open for FILE types +;- + +;- LOB Buffering Flush Flags - +(defconstant +OCI-LOB-BUFFER-FREE+ 1) ; +(defconstant +OCI-LOB-BUFFER-NOFREE+ 2) ; +;- + +;- OCI Statement Types - + +(defconstant +oci-stmt-select+ 1) ; select statement +(defconstant +oci-stmt-update+ 2) ; update statement +(defconstant +oci-stmt-delete+ 3) ; delete statement +(defconstant +oci-stmt-insert+ 4) ; insert statement +(defconstant +oci-stmt-create+ 5) ; create statement +(defconstant +oci-stmt-drop+ 6) ; drop statement +(defconstant +oci-stmt-alter+ 7) ; alter statement +(defconstant +oci-stmt-begin+ 8) ; begin ... (pl/sql statement) +(defconstant +oci-stmt-declare+ 9) ; declare .. (pl/sql statement ) +;- + +;- OCI Parameter Types - +(defconstant +OCI-PTYPE-UNK+ 0) ; unknown +(defconstant +OCI-PTYPE-TABLE+ 1) ; table +(defconstant +OCI-PTYPE-VIEW+ 2) ; view +(defconstant +OCI-PTYPE-PROC+ 3) ; procedure +(defconstant +OCI-PTYPE-FUNC+ 4) ; function +(defconstant +OCI-PTYPE-PKG+ 5) ; package +(defconstant +OCI-PTYPE-TYPE+ 6) ; user-defined type +(defconstant +OCI-PTYPE-SYN+ 7) ; synonym +(defconstant +OCI-PTYPE-SEQ+ 8) ; sequence +(defconstant +OCI-PTYPE-COL+ 9) ; column +(defconstant +OCI-PTYPE-ARG+ 10) ; argument +(defconstant +OCI-PTYPE-LIST+ 11) ; list +(defconstant +OCI-PTYPE-TYPE-ATTR+ 12) ; user-defined type's attribute +(defconstant +OCI-PTYPE-TYPE-COLL+ 13) ; collection type's element +(defconstant +OCI-PTYPE-TYPE-METHOD+ 14) ; user-defined type's method +(defconstant +OCI-PTYPE-TYPE-ARG+ 15) ; user-defined type method's argument +(defconstant +OCI-PTYPE-TYPE-RESULT+ 16) ; user-defined type method's result +;- + +;- OCI List Types - +(defconstant +OCI-LTYPE-UNK+ 0) ; unknown +(defconstant +OCI-LTYPE-COLUMN+ 1) ; column list +(defconstant +OCI-LTYPE-ARG-PROC+ 2) ; procedure argument list +(defconstant +OCI-LTYPE-ARG-FUNC+ 3) ; function argument list +(defconstant +OCI-LTYPE-SUBPRG+ 4) ; subprogram list +(defconstant +OCI-LTYPE-TYPE-ATTR+ 5) ; type attribute +(defconstant +OCI-LTYPE-TYPE-METHOD+ 6) ; type method +(defconstant +OCI-LTYPE-TYPE-ARG-PROC+ 7) ; type method w/o result argument list +(defconstant +OCI-LTYPE-TYPE-ARG-FUNC+ 8) ; type method w/result argument list + +;; typecodes + diff --git a/db-oracle/oracle-loader.cl b/db-oracle/oracle-loader.cl deleted file mode 100644 index d35c5cc..0000000 --- a/db-oracle/oracle-loader.cl +++ /dev/null @@ -1,119 +0,0 @@ -;;; -*- Mode: Lisp -*- -;;; $Id: oracle-loader.cl,v 1.1 2002/09/18 07:43:41 kevin Exp $ -;;; -;;; MaiSQL --- Common Lisp Interface Layer to SQL Databases -;;; This is copyrighted software. See documentation for terms. -;;; -;;; oracle-loader.cl --- Foreign Object Loader for Oracle - -(in-package :clsql-oracle) - -;; Load the foreign library - -(eval-when (:load-toplevel :compile-toplevel) - (defvar *oracle-home* - nil - "The root of the Oracle installation, usually $ORACLE_HOME is set to this.") - (unless *oracle-home* - (setf *oracle-home* - (cdr (assoc ':ORACLE_HOME ext:*environment-list* :test #'eq))))) - -(defparameter *oracle-libs* - '(#-oracle-9i "rdbms/lib/ssdbaed.o" - "rdbms/lib/defopt.o" - #-oracle-9i "rdbms/lib/homts.o" - "lib/nautab.o" - "lib/naeet.o" - "lib/naect.o" - "lib/naedhs.o" - #-oracle-9i"lib/libnsslb8.a" - #+oracle-9i "lib/homts.o" - ) - "Oracle client libraries, relative to ORACLE_HOME.") - -(defun make-oracle-load-path () - (mapcar (lambda (x) - (concatenate 'string *oracle-home* "/" x)) - *oracle-libs*)) - - -; ;(defparameter *oracle-so-libraries* -; ;; `(,(concatenate 'string "-L" *oracle-home* "/lib/") -; '( -; "-lclntsh" -; "-lnetv2" -; "-lnttcp" -; "-lnetwork" -; "-lncr" -; "-lclient" -; "-lvsn" -; "-lcommon" -; "-lgeneric" -; "-lmm" -; "-lnlsrtl3" -; "-lcore4" -; "-lnlsrtl3" -; "-lepc" -; "-ldl" -; "-lm") -; "List of library flags needed to be passed to ld to load the -; Oracle client library succesfully. If this differs at your site, -; set *oracle-so-libraries* to the right path before compiling or -; loading the system.") - - -#-oracle-9i -(defun oracle-libraries () - `(,(concatenate 'string - "-L" *oracle-home* "/lib") - "-lagtsh" -;; "-locijdbc8" - "-lclntsh" - "-lclient8" - "-lvsn8" - "-lcommon8" - "-lskgxp8" - "-lmm" - "-lnls8" - "-lcore8" - "-lgeneric8" - "-ltrace8" - "-ldl" - "-lm")) - -;; "List of library flags needed to be passed to ld to load the -;;Oracle client library succesfully. If this differs at your site, -;;set *oracle-so-libraries* to the right path before compiling or -;;loading the system.") - -#+oracle-9i -(defun oracle-libraries () - `(,(concatenate 'string - "-L" *oracle-home* "/lib") - "-lagent9" - "-lagtsh" -;; "-locijdbc8" - "-lclntsh" - "-lclntst9" - "-lclient9" - "-lvsn9" - "-lcommon9" - "-lskgxp9" - "-lmm" - "-lnls9" - "-lcore9" - "-lgeneric9" - "-ltrace9" - "-ldl" - #+redhat-linux "-L/usr/lib/gcc-lib/i386-redhat-linux/2.96" - "-lgcc" - "-lm")) - -(defmethod database-type-load-foreign ((database-type (eql :oracle))) - (progv '(sys::*dso-linker*) - '("/usr/bin/ld") - (ext:load-foreign (make-oracle-load-path) - :libraries (oracle-libraries)))) - - -(database-type-load-foreign :oracle) diff --git a/db-oracle/oracle-loader.lisp b/db-oracle/oracle-loader.lisp new file mode 100644 index 0000000..b7f3b84 --- /dev/null +++ b/db-oracle/oracle-loader.lisp @@ -0,0 +1,119 @@ +;;; -*- Mode: Lisp -*- +;;; $Id: oracle-loader.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $ +;;; +;;; MaiSQL --- Common Lisp Interface Layer to SQL Databases +;;; This is copyrighted software. See documentation for terms. +;;; +;;; oracle-loader.cl --- Foreign Object Loader for Oracle + +(in-package :clsql-oracle) + +;; Load the foreign library + +(eval-when (:load-toplevel :compile-toplevel) + (defvar *oracle-home* + nil + "The root of the Oracle installation, usually $ORACLE_HOME is set to this.") + (unless *oracle-home* + (setf *oracle-home* + (cdr (assoc ':ORACLE_HOME ext:*environment-list* :test #'eq))))) + +(defparameter *oracle-libs* + '(#-oracle-9i "rdbms/lib/ssdbaed.o" + "rdbms/lib/defopt.o" + #-oracle-9i "rdbms/lib/homts.o" + "lib/nautab.o" + "lib/naeet.o" + "lib/naect.o" + "lib/naedhs.o" + #-oracle-9i"lib/libnsslb8.a" + #+oracle-9i "lib/homts.o" + ) + "Oracle client libraries, relative to ORACLE_HOME.") + +(defun make-oracle-load-path () + (mapcar (lambda (x) + (concatenate 'string *oracle-home* "/" x)) + *oracle-libs*)) + + +; ;(defparameter *oracle-so-libraries* +; ;; `(,(concatenate 'string "-L" *oracle-home* "/lib/") +; '( +; "-lclntsh" +; "-lnetv2" +; "-lnttcp" +; "-lnetwork" +; "-lncr" +; "-lclient" +; "-lvsn" +; "-lcommon" +; "-lgeneric" +; "-lmm" +; "-lnlsrtl3" +; "-lcore4" +; "-lnlsrtl3" +; "-lepc" +; "-ldl" +; "-lm") +; "List of library flags needed to be passed to ld to load the +; Oracle client library succesfully. If this differs at your site, +; set *oracle-so-libraries* to the right path before compiling or +; loading the system.") + + +#-oracle-9i +(defun oracle-libraries () + `(,(concatenate 'string + "-L" *oracle-home* "/lib") + "-lagtsh" +;; "-locijdbc8" + "-lclntsh" + "-lclient8" + "-lvsn8" + "-lcommon8" + "-lskgxp8" + "-lmm" + "-lnls8" + "-lcore8" + "-lgeneric8" + "-ltrace8" + "-ldl" + "-lm")) + +;; "List of library flags needed to be passed to ld to load the +;;Oracle client library succesfully. If this differs at your site, +;;set *oracle-so-libraries* to the right path before compiling or +;;loading the system.") + +#+oracle-9i +(defun oracle-libraries () + `(,(concatenate 'string + "-L" *oracle-home* "/lib") + "-lagent9" + "-lagtsh" +;; "-locijdbc8" + "-lclntsh" + "-lclntst9" + "-lclient9" + "-lvsn9" + "-lcommon9" + "-lskgxp9" + "-lmm" + "-lnls9" + "-lcore9" + "-lgeneric9" + "-ltrace9" + "-ldl" + #+redhat-linux "-L/usr/lib/gcc-lib/i386-redhat-linux/2.96" + "-lgcc" + "-lm")) + +(defmethod database-type-load-foreign ((database-type (eql :oracle))) + (progv '(sys::*dso-linker*) + '("/usr/bin/ld") + (ext:load-foreign (make-oracle-load-path) + :libraries (oracle-libraries)))) + + +(database-type-load-foreign :oracle) diff --git a/db-oracle/oracle-objects.cl b/db-oracle/oracle-objects.cl deleted file mode 100644 index 23f22d7..0000000 --- a/db-oracle/oracle-objects.cl +++ /dev/null @@ -1,91 +0,0 @@ -(in-package :clsql-oracle) - -(defparameter *oracle-default-varchar2-length* "512") - -(defmethod database-get-type-specifier - (type args (database oracle-database)) - (declare (ignore type args)) - (concatenate 'string "VARCHAR2(" *oracle-default-varchar2-length* ")")) - -(defmethod database-get-type-specifier - ((type (eql 'integer)) args (database oracle-database)) - (if args - (format nil "NUMBER(~A,~A)" - (or (first args) 38) (or (second args) 0)) - "NUMBER(38,0)")) - -(defmethod database-get-type-specifier - ((type (eql 'simple-base-string)) args (database oracle-database)) - (if args - (format nil "VARCHAR2(~A)" (car args)) - (concatenate 'string "VARCHAR2(" *oracle-default-varchar2-length* ")"))) - -(defmethod database-get-type-specifier - ((type (eql 'simple-string)) args (database oracle-database)) - (if args - (format nil "VARCHAR2(~A)" (car args)) - (concatenate 'string "VARCHAR2(" *oracle-default-varchar2-length* ")"))) - -(defmethod database-get-type-specifier - ((type (eql 'string)) args (database oracle-database)) - (if args - (format nil "VARCHAR2(~A)" (car args)) - (concatenate 'string "VARCHAR2(" *oracle-default-varchar2-length* ")")) - "VARCHAR2(512)") - -(defmethod database-get-type-specifier - ((type (eql 'raw-string)) args (database oracle-database)) - (if args - (format nil "VARCHAR2(~A)" (car args)) - (concatenate 'string "VARCHAR2(" *oracle-default-varchar2-length* ")")) - "VARCHAR2(256)") - -(defmethod database-get-type-specifier - ((type (eql 'float)) args (database oracle-database)) - (if args - (format nil "NUMBER(~A,~A)" - (or (first args) 38) (or (second args) 38)) - "NUMBER")) - -(defmethod database-get-type-specifier - ((type (eql 'long-float)) args (database oracle-database)) - (if args - (format nil "NUMBER(~A,~A)" - (or (first args) 38) (or (second args) 38)) - "NUMBER")) - -(defmethod read-sql-value (val type (database oracle-database)) - (declare (ignore type database)) - ;;(format t "value is \"~A\" of type ~A~%" val (type-of val)) - (etypecase val - (string - (read-from-string val)) - (symbol - nil))) - -(defmethod read-sql-value (val (type (eql 'string)) database) - (declare (ignore database)) - val) - -(defmethod read-sql-value - (val (type (eql 'integer)) (database oracle-database)) - (declare (ignore database)) - val) - -(defmethod read-sql-value (val (type (eql 'float)) (database oracle-database)) - val) - -;;; LOCAL-TIME stuff that needs to go into hooks -#+local-time -(defmethod clsql-sys::database-get-type-specifier - ((type (eql 'local-time::local-time)) args (database oracle-database)) - (declare (ignore args)) - "DATE") - -#+local-time -(defmethod clsql-sys::database-get-type-specifier - ((type (eql 'local-time::duration)) - args - (database oracle-database)) - (declare (ignore args)) - "NUMBER(38)") diff --git a/db-oracle/oracle-objects.lisp b/db-oracle/oracle-objects.lisp new file mode 100644 index 0000000..23f22d7 --- /dev/null +++ b/db-oracle/oracle-objects.lisp @@ -0,0 +1,91 @@ +(in-package :clsql-oracle) + +(defparameter *oracle-default-varchar2-length* "512") + +(defmethod database-get-type-specifier + (type args (database oracle-database)) + (declare (ignore type args)) + (concatenate 'string "VARCHAR2(" *oracle-default-varchar2-length* ")")) + +(defmethod database-get-type-specifier + ((type (eql 'integer)) args (database oracle-database)) + (if args + (format nil "NUMBER(~A,~A)" + (or (first args) 38) (or (second args) 0)) + "NUMBER(38,0)")) + +(defmethod database-get-type-specifier + ((type (eql 'simple-base-string)) args (database oracle-database)) + (if args + (format nil "VARCHAR2(~A)" (car args)) + (concatenate 'string "VARCHAR2(" *oracle-default-varchar2-length* ")"))) + +(defmethod database-get-type-specifier + ((type (eql 'simple-string)) args (database oracle-database)) + (if args + (format nil "VARCHAR2(~A)" (car args)) + (concatenate 'string "VARCHAR2(" *oracle-default-varchar2-length* ")"))) + +(defmethod database-get-type-specifier + ((type (eql 'string)) args (database oracle-database)) + (if args + (format nil "VARCHAR2(~A)" (car args)) + (concatenate 'string "VARCHAR2(" *oracle-default-varchar2-length* ")")) + "VARCHAR2(512)") + +(defmethod database-get-type-specifier + ((type (eql 'raw-string)) args (database oracle-database)) + (if args + (format nil "VARCHAR2(~A)" (car args)) + (concatenate 'string "VARCHAR2(" *oracle-default-varchar2-length* ")")) + "VARCHAR2(256)") + +(defmethod database-get-type-specifier + ((type (eql 'float)) args (database oracle-database)) + (if args + (format nil "NUMBER(~A,~A)" + (or (first args) 38) (or (second args) 38)) + "NUMBER")) + +(defmethod database-get-type-specifier + ((type (eql 'long-float)) args (database oracle-database)) + (if args + (format nil "NUMBER(~A,~A)" + (or (first args) 38) (or (second args) 38)) + "NUMBER")) + +(defmethod read-sql-value (val type (database oracle-database)) + (declare (ignore type database)) + ;;(format t "value is \"~A\" of type ~A~%" val (type-of val)) + (etypecase val + (string + (read-from-string val)) + (symbol + nil))) + +(defmethod read-sql-value (val (type (eql 'string)) database) + (declare (ignore database)) + val) + +(defmethod read-sql-value + (val (type (eql 'integer)) (database oracle-database)) + (declare (ignore database)) + val) + +(defmethod read-sql-value (val (type (eql 'float)) (database oracle-database)) + val) + +;;; LOCAL-TIME stuff that needs to go into hooks +#+local-time +(defmethod clsql-sys::database-get-type-specifier + ((type (eql 'local-time::local-time)) args (database oracle-database)) + (declare (ignore args)) + "DATE") + +#+local-time +(defmethod clsql-sys::database-get-type-specifier + ((type (eql 'local-time::duration)) + args + (database oracle-database)) + (declare (ignore args)) + "NUMBER(38)") diff --git a/db-oracle/oracle-package.cl b/db-oracle/oracle-package.cl deleted file mode 100644 index ef25caf..0000000 --- a/db-oracle/oracle-package.cl +++ /dev/null @@ -1,14 +0,0 @@ -;;; -*- Mode: Lisp -*- -;;; $Id: oracle-package.cl,v 1.1 2002/09/18 07:43:41 kevin Exp $ -;;; -;;; This is copyrighted software. See documentation for terms. - -(in-package :cl-user) - -(defpackage :clsql-oracle - (:nicknames :oracle) - (:use :common-lisp :clsql-sys "ALIEN" "C-CALL" "SYSTEM") - (:export #:oracle-database - #:*oracle-so-load-path* - #:*oracle-so-libraries*) - (:documentation "This is the CLSQL interface to Oracle.")) diff --git a/db-oracle/oracle-package.lisp b/db-oracle/oracle-package.lisp new file mode 100644 index 0000000..2d78a05 --- /dev/null +++ b/db-oracle/oracle-package.lisp @@ -0,0 +1,14 @@ +;;; -*- Mode: Lisp -*- +;;; $Id: oracle-package.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $ +;;; +;;; This is copyrighted software. See documentation for terms. + +(in-package :cl-user) + +(defpackage :clsql-oracle + (:nicknames :oracle) + (:use :common-lisp :clsql-sys "ALIEN" "C-CALL" "SYSTEM") + (:export #:oracle-database + #:*oracle-so-load-path* + #:*oracle-so-libraries*) + (:documentation "This is the CLSQL interface to Oracle.")) diff --git a/db-oracle/oracle-sql.cl b/db-oracle/oracle-sql.cl deleted file mode 100644 index 76fdad6..0000000 --- a/db-oracle/oracle-sql.cl +++ /dev/null @@ -1,856 +0,0 @@ -;;; -*- Mode: Lisp -*- -;;; $Id: oracle-sql.cl,v 1.1 2002/09/18 07:43:41 kevin Exp $ - -;;; MaiSQL --- Common Lisp Interface Layer to SQL Databases -;;; This is copyrighted software. See documentation for terms. -;;; -;;; oracle-sql.lisp --- SQL-Interface implementation for Oracle -;;; -;;; derived from postgresql.lisp - -(in-package :clsql-oracle) - -(defmethod database-initialize-database-type - ((database-type (eql :oracle))) - t) - -;;;; KLUDGE: The original prototype of this code was implemented using -;;;; lots of special variables holding MAKE-ALIEN values. When I was -;;;; first converting it to use WITH-ALIEN variables, I was confused -;;;; about the behavior of MAKE-ALIEN and WITH-ALIEN; I thought that -;;;; (MAKE-ALIEN TYPEFOO) returned the same type of object as is bound -;;;; to the name BAR by (WITH-ALIEN ((BAR TYPEFOO)) ..). In fact the -;;;; value returned by MAKE-ALIEN has an extra level of indirection -;;;; relative to the value bound by WITH-ALIEN, i.e. (DEREF -;;;; (MAKE-ALIEN TYPEFOO)) has the same type as the value bound to the -;;;; name BAR by (WITH-ALIEN ((BAR TYPEFOO)) ..). Laboring under my -;;;; misunderstanding, I was unable to use ordinary scalars bound by -;;;; WITH-ALIEN, and I ended up giving up and deciding to work around -;;;; this apparent bug in CMUCL by using 1-element arrays instead. -;;;; This "workaround" for my misunderstanding is obviously unnecessary -;;;; and confusing, but still remains in the code. -- WHN 20000106 - - -;;;; arbitrary parameters, tunable for performance or other reasons - -;;; the number of table rows that we buffer at once when reading a table -;;; -;;; CMUCL has a compiled-in limit on how much C data can be allocated -;;; (through malloc() and friends) at any given time, typically 8 Mb. -;;; Setting this constant to a moderate value should make it less -;;; likely that we'll have to worry about the CMUCL limit. -(defconstant +n-buf-rows+ 200) -;;; the number of characters that we allocate for an error message buffer -(defconstant +errbuf-len+ 512) - -;;; utilities for mucking around with C-level stuff - -;; Return the address of ALIEN-OBJECT (like the C operator "&"). -;; -;; The INDICES argument is useful to give the ALIEN-OBJECT the -;; expected number of zero indices, especially when we have a bunch of -;; 1-element arrays running around due to the workaround for the CMUCL -;; 18b WITH-ALIEN scalar bug. - -(defmacro c-& (alien-object &rest indices) - `(addr (deref ,alien-object ,@indices))) - -;; constants - from OCI? - -(defconstant +var-not-in-list+ 1007) -(defconstant +no-data-found+ 1403) -(defconstant +null-value-returned+ 1405) -(defconstant +field-truncated+ 1406) - -(defconstant SQLT-INT 3) -(defconstant SQLT-STR 5) -(defconstant SQLT-FLT 4) -(defconstant SQLT-DATE 12) - -;;; Note that despite the suggestive class name (and the way that the -;;; *DEFAULT-DATABASE* variable holds an object of this class), a DB -;;; object is not actually a database but is instead a connection to a -;;; database. Thus, there's no obstacle to having any number of DB -;;; objects referring to the same database. - -(defclass oracle-database (database) ; was struct db - ((envhp - :reader envhp - :initarg :envhp - :type (alien (* (* t))) - :documentation - "OCI environment handle") - (errhp - :reader errhp - :initarg :errhp - :type (alien (* (* t))) - :documentation - "OCI error handle") - (svchp - :reader svchp - :initarg :svchp - :type (alien (* (* t))) - :documentation - "OCI service context handle") - (data-source-name - :initarg :dsn - :initform nil - :documentation - "optional data source name (used only for debugging/printing)") - (user - :initarg :user - :reader user - :type string - :documentation - "the \"user\" value given when data source connection was made") - (date-format - :initarg :date-format - :reader date-format - :initform "YYYY-MM-DD HH24:MI:SS\"+00\"") - (date-format-length - :type number - :documentation - "Each database connection can be configured with its own date -output format. In order to extract date strings from output buffers -holding multiple date strings in fixed-width fields, we need to know -the length of that format."))) - - -;;; Handle the messy case of return code=+oci-error+, querying the -;;; system for subcodes and reporting them as appropriate. ERRHP and -;;; NULLS-OK are as in the OERR function. - -(defun handle-oci-error (&key database nulls-ok) - (cond (database - (with-slots (errhp) - database - (with-alien ((errbuf (array char #.+errbuf-len+)) - (errcode (array long 1))) - (setf (deref errbuf 0) 0) ; i.e. init to empty string - (setf (deref errcode 0) 0) - (oci-error-get (deref errhp) 1 "" (c-& errcode 0) (c-& errbuf 0) +errbuf-len+ +oci-htype-error+) - (let ((subcode (deref errcode 0))) - (unless (and nulls-ok (= subcode +null-value-returned+)) - (error 'clsql-sql-error - :database database - :errno subcode - :error (cast (c-& errbuf 0) c-string))))))) - (nulls-ok - (error 'clsql-sql-error - :database database - :error "can't handle NULLS-OK without ERRHP")) - (t - (error 'clsql-sql-error - :database database - :error "OCI Error (and no ERRHP available to find subcode)")))) - -;;; Require an OCI success code. -;;; -;;; (The ordinary OCI error reporting mechanisms uses a fair amount of -;;; machinery (environments and other handles). In order to get to -;;; where we can use these mechanisms, we have to be able to allocate -;;; the machinery. The functions for allocating the machinery can -;;; return errors (e.g. out of memory) but shouldn't. Wrapping this function -;;; around function calls to such have-to-succeed functions enforces -;;; this condition.) - -(defun osucc (code) - (declare (type fixnum code)) - (unless (= code +oci-success+) - (error 'dbi-error - :format-control "unexpected OCI failure, code=~S" - :format-arguments (list code)))) - - -;;; Enabling this can be handy for low-level debugging. -#+nil -(progn - (trace oci-initialize #+oci-8-1-5 oci-env-create oci-handle-alloc oci-logon - oci-error-get oci-stmt-prepare oci-stmt-execute - oci-param-get oci-logon oci-attr-get oci-define-by-pos oci-stmt-fetch) - (setf debug::*debug-print-length* nil)) - - -;;;; the OCI library, part V: converting from OCI representations to Lisp -;;;; representations - -;; Return the INDEXth string of the OCI array, represented as Lisp -;; SIMPLE-STRING. SIZE is the size of the fixed-width fields used by -;; Oracle to store strings within the array. - -;; In the wild world of databases, trailing spaces aren't generally -;; significant, since e.g. "LARRY " and "LARRY " are the same string -;; stored in different fixed-width fields. OCI drops trailing spaces -;; for us in some cases but apparently not for fields of fixed -;; character width, e.g. -;; -;; (dbi:sql "create table employees (name char(15), job char(15), city -;; char(15), rate float)" :db orcl :types :auto) -;; In order to map the "same string" property above onto Lisp equality, -;; we drop trailing spaces in all cases: - -(defun deref-oci-string (arrayptr string-index size) - (declare (type (alien (* char)) arrayptr)) - (declare (type (mod #.+n-buf-rows+) string-index)) - (declare (type (and unsigned-byte fixnum) size)) - (let* ((raw (cast (addr (deref arrayptr (* string-index size))) c-string)) - (trimmed (string-trim " " raw))) - (if (equal trimmed "NULL") nil trimmed))) - -;; the OCI library, part Z: no-longer used logic to convert from -;; Oracle's binary date representation to Common Lisp's native date -;; representation - -#+nil -(defvar +oci-date-bytes+ 7) - -;;; Return the INDEXth date in the OCI array, represented as -;;; a Common Lisp "universal time" (i.e. seconds since 1900). - -#+nil -(defun deref-oci-date (arrayptr index) - (oci-date->universal-time (addr (deref arrayptr - (* index +oci-date-bytes+))))) -#+nil -(defun oci-date->universal-time (oci-date) - (declare (type (alien (* char)) oci-date)) - (flet (;; a character from OCI-DATE, interpreted as an unsigned byte - (ub (i) - (declare (type (mod #.+oci-date-bytes+) i)) - (mod (deref oci-date i) 256))) - (let* ((century (* (- (ub 0) 100) 100)) - (year (+ century (- (ub 1) 100))) - (month (ub 2)) - (day (ub 3)) - (hour (1- (ub 4))) - (minute (1- (ub 5))) - (second (1- (ub 6)))) - (encode-universal-time second minute hour day month year)))) - -;; Return (VALUES ALL-TABLES COLUMN-NAMES), where ALL-TABLES is a -;; table containing one row for each table available in DB, and -;; COLUMN-NAMES is a list of header names for the columns in -;; ALL-TABLES. -;; -;; The Allegro version also accepted a HSTMT argument. - -;(defmethod database-list-tables ((db oracle-database)) -; (sql:query "select '',OWNER,TABLE_NAME,TABLE_TYPE,'' from all_catalog")) - - -(defmethod list-all-user-database-tables ((db oracle-database)) - (unless db - (setf db sql:*default-database*)) - (values (database-query "select TABLE_NAME from all_catalog - where owner <> 'PUBLIC' and owner <> 'SYSTEM' and owner <> 'SYS'" - db))) - - -(defmethod database-list-tables ((database oracle-database) - &key (system-tables nil)) - (if system-tables - (select [table_name] :from [all_catalog]) - (select [table_name] :from [all_catalog] - :where [and [<> [owner] "PUBLIC"] - [<> [owner] "SYSTEM"] - [<> [owner] "SYS"]] - :flatp t))) - -;; Return a list of all columns in TABLE. -;; -;; The Allegro version of this also returned a second value. - -(defmethod list-all-table-columns (table (db oracle-database)) - (declare (type string table)) - (unless db - (setf db (default-database))) - (let* ((sql-stmt (concatenate - 'simple-string - "select " - "''," - "all_tables.OWNER," - "''," - "user_tab_columns.COLUMN_NAME," - "user_tab_columns.DATA_TYPE from user_tab_columns," - "all_tables where all_tables.table_name = '" table "'" - " and user_tab_columns.table_name = '" table "'")) - (preresult (sql sql-stmt :db db :types :auto))) - ;; PRERESULT is like RESULT except that it has a name instead of - ;; type codes in the fifth column of each row. To fix this, we - ;; destructively modify PRERESULT. - (dolist (preresult-row preresult) - (setf (fifth preresult-row) - (if (find (fifth preresult-row) - #("NUMBER" "DATE") - :test #'string=) - 2 ; numeric - 1))) ; string - preresult)) - -(defmethod database-list-attributes (table (database oracle-database)) - (let* ((relname (etypecase table - (sql-sys::sql-ident - (string-upcase - (symbol-name (slot-value table 'sql-sys::name)))) - (string table)))) - (select [user_tab_columns column_name] - :from [user_tab_columns] - :where [= [user_tab_columns table_name] relname] - :flatp t))) - - - -;; Return one row of the table referred to by QC, represented as a -;; list; or if there are no more rows, signal an error if EOF-ERRORP, -;; or return EOF-VALUE otherwise. - -;; KLUDGE: This CASE statement is a strong sign that the code would be -;; cleaner if CD were made into an abstract class, we made variant -;; classes for CD-for-column-of-strings, CD-for-column-of-floats, -;; etc., and defined virtual functions to handle operations like -;; get-an-element-from-column. (For a small special purpose module -;; like this, would arguably be overkill, so I'm not going to do it -;; now, but if this code ends up getting more complicated in -;; maintenance, it would become a really good idea.) - -;; Arguably this would be a good place to signal END-OF-FILE, but -;; since the ANSI spec specifically says that END-OF-FILE means a -;; STREAM which has no more data, and QC is not a STREAM, we signal -;; DBI-ERROR instead. - -(defun fetch-row (qc &optional (eof-errorp t) eof-value) - (declare (optimize (speed 3))) - (cond ((zerop (qc-n-from-oci qc)) - (if eof-errorp - (dbi-error "no more rows available in ~S" qc) - eof-value)) - ((>= (qc-n-to-dbi qc) - (qc-n-from-oci qc)) - (refill-qc-buffers qc) - (fetch-row qc nil eof-value)) - (t - (let ((cds (qc-cds qc)) - (reversed-result nil) - (irow (qc-n-to-dbi qc))) - (dotimes (icd (length cds)) - (let* ((cd (aref cds icd)) - (b (alien-resource-buffer (cd-buffer cd))) - (value - (let ((arb (alien-resource-buffer (cd-indicators cd)))) - (declare (type (alien (* (alien:signed 16))) arb)) - (unless (= (deref arb irow) -1) - (ecase (cd-oci-data-type cd) - (#.SQLT-STR (deref-oci-string b irow (cd-sizeof cd))) - (#.SQLT-FLT (deref (the (alien (* double)) b) irow)) - (#.SQLT-INT (deref (the (alien (* int)) b) irow)) - (#.SQLT-DATE (deref-oci-string b irow (cd-sizeof cd)))))))) - (push value reversed-result))) - (incf (qc-n-to-dbi qc)) - (nreverse reversed-result))))) - -(defun refill-qc-buffers (qc) - (with-slots (errhp) - (qc-db qc) - (setf (qc-n-to-dbi qc) 0) - (cond ((qc-oci-end-seen-p qc) - (setf (qc-n-from-oci qc) 0)) - (t - (let ((oci-code (%oci-stmt-fetch (deref (qc-stmthp qc)) - (deref errhp) - +n-buf-rows+ - +oci-fetch-next+ +oci-default+))) - (ecase oci-code - (#.+oci-success+ (values)) - (#.+oci-no-data+ (setf (qc-oci-end-seen-p qc) t) - (values)) - (#.+oci-error+ (handle-oci-error :database (qc-db qc) - :nulls-ok t)))) - (with-alien ((rowcount (array unsigned-long 1))) - (oci-attr-get (deref (qc-stmthp qc)) +oci-htype-stmt+ - (c-& rowcount 0) nil +oci-attr-row-count+ - (deref errhp)) - (setf (qc-n-from-oci qc) - (- (deref rowcount 0) (qc-total-n-from-oci qc))) - (when (< (qc-n-from-oci qc) +n-buf-rows+) - (setf (qc-oci-end-seen-p qc) t)) - (setf (qc-total-n-from-oci qc) - (deref rowcount 0))))) - (values))) - -;; the guts of the SQL function -;; -;; (like the SQL function, but with the QUERY argument hardwired to T, so -;; that the return value is always a cursor instead of a list) - -;; Is this a SELECT statement? SELECT statements are handled -;; specially by OCIStmtExecute(). (Non-SELECT statements absolutely -;; require a nonzero iteration count, while the ordinary choice for a -;; SELECT statement is a zero iteration count. - -;; SELECT statements are the only statements which return tables. We -;; don't free STMTHP in this case, but instead give it to the new -;; QUERY-CURSOR, and the new QUERY-CURSOR becomes responsible for -;; freeing the STMTHP when it is no longer needed. - -(defun sql-stmt-exec (sql-stmt-string db &key types) - (with-slots (envhp svchp errhp) - db - (let ((stmthp (make-alien (* t)))) - (with-alien ((stmttype (array unsigned-short 1))) - - (oci-handle-alloc (deref envhp) (c-& stmthp) +oci-htype-stmt+ 0 nil) - (oci-stmt-prepare (deref stmthp) (deref errhp) - sql-stmt-string (length sql-stmt-string) - +oci-ntv-syntax+ +oci-default+ :database db) - (oci-attr-get (deref stmthp) +oci-htype-stmt+ - (c-& stmttype 0) nil +oci-attr-stmt-type+ - (deref errhp) :database db) - (let* ((select-p (= (deref stmttype 0) 1)) - (iters (if select-p 0 1))) - - (oci-stmt-execute (deref svchp) (deref stmthp) (deref errhp) - iters 0 nil nil +oci-default+ :database db) - (cond (select-p - (make-query-cursor db stmthp types)) - (t - (oci-handle-free (deref stmthp) +oci-htype-stmt+) - nil))))))) - - -;; Return a QUERY-CURSOR representing the table returned from the OCI -;; operation done through STMTHP. TYPES is the argument of the same -;; name from the external SQL function, controlling type conversion -;; of the returned arguments. - -(defun make-query-cursor (db stmthp types) - (let ((qc (%make-query-cursor :db db - :stmthp stmthp - :cds (make-query-cursor-cds db stmthp types)))) - (refill-qc-buffers qc) - qc)) - - -;; the hairy part of MAKE-QUERY-CURSOR: Ask OCI for information -;; about table columns, translate the information into a Lisp -;; vector of column descriptors, and return it. - -;; Allegro defines several flavors of type conversion, but this -;; implementation only supports the :AUTO flavor. - -;; A note of explanation: OCI's internal number format uses 21 -;; bytes (42 decimal digits). 2 separate (?) one-byte fields, -;; scale and precision, are used to deduce the nature of these -;; 21 bytes. See pp. 3-10, 3-26, and 6-13 of OCI documentation -;; for more details. - -;; When calling OCI C code to handle the conversion, we have -;; only two numeric types available to pass the return value: -;; double-float and signed-long. It would be possible to -;; bypass the OCI conversion functions and write Lisp code -;; which reads the 21-byte field directly and decodes -;; it. However this is left as an exercise for the reader. :-) - -;; The following table describes the mapping, based on the implicit -;; assumption that C's "signed long" type is a 32-bit integer. -;; -;; Internal Values SQL Type C Return Type -;; =============== ======== ============= -;; Precision > 0 SCALE = -127 FLOAT --> double-float -;; Precision > 0 && <=9 SCALE = 0 INTEGER --> signed-long -;; Precision = 0 || > 9 SCALE = 0 BIG INTEGER --> double-float -;; Precision > 0 SCALE > 0 DECIMAL --> double-float - -;; (OCI uses 1-based indexing here.) - -;; KLUDGE: This should work for all other data types except those -;; which don't actually fit in their fixed-width field (BLOBs and the -;; like). As Winton says, we (Cadabra) don't need to worry much about -;; those, since we can't reason with them, so we don't use them. But -;; for a more general application it'd be good to have a more -;; selective and rigorously correct test here for whether we can -;; actually handle the given DEREF-DTYPE value. -- WHN 20000106 - -;; Note: The OCI documentation doesn't seem to say whether the COLNAME -;; value returned here is a newly-allocated copy which we're -;; responsible for freeing, or a pointer into some system copy which -;; will be freed when the system itself is shut down. But judging -;; from the way that the result is used in the cdemodsa.c example -;; program, it looks like the latter: we should make our own copy of -;; the value, but not try to free it. - -;; WORKAROUND: OCI seems to return ub2 values for the -;; +oci-attr-data-size+ attribute even though its documentation claims -;; that it returns a ub4, and even though the associated "sizep" value -;; is 4, not 2. In order to make the code here work reliably, without -;; having to patch it later if OCI is ever fixed to match its -;; documentation, we pre-zero COLSIZE before making the call into OCI. - -;; To exercise the weird OCI behavior (thereby blowing up the code -;; below, beware!) try setting this value into COLSIZE, calling OCI, -;; then looking at the value in COLSIZE. (setf colsize #x12345678) -;; debugging only - - -(defun make-query-cursor-cds (database stmthp types) - (declare (optimize (speed 3)) - (type oracle-database database) - (type (alien (* (* t))) stmthp)) - (with-slots (errhp) - database - (unless (eq types :auto) - (error "unsupported TYPES value")) - (with-alien ((dtype unsigned-short 1) - (parmdp (* t)) - (precision (unsigned 8)) - (scale (signed 8)) - (colname c-string) - (colnamelen unsigned-long) - (colsize unsigned-long) - (colsizesize unsigned-long) - (defnp (* t))) - (let ((buffer nil) - (sizeof nil)) - (do ((icolumn 0 (1+ icolumn)) - (cds-as-reversed-list nil)) - ((not (eql (oci-param-get (deref stmthp) +oci-htype-stmt+ - (deref errhp) (addr parmdp) - (1+ icolumn) :database database) - +oci-success+)) - (coerce (reverse cds-as-reversed-list) 'simple-vector)) - ;; Decode type of ICOLUMNth column into a type we're prepared to - ;; handle in Lisp. - (oci-attr-get parmdp +oci-dtype-param+ (addr dtype) - nil +oci-attr-data-type+ (deref errhp)) - (case dtype - (#.SQLT-DATE - (setf buffer (acquire-alien-resource char (* 32 +n-buf-rows+))) - (setf sizeof 32 dtype #.SQLT-STR)) - (2 ;; number - ;;(oci-attr-get parmdp +oci-dtype-param+ - ;;(addr precision) nil +oci-attr-precision+ - ;;(deref errhp)) - (oci-attr-get parmdp +oci-dtype-param+ - (addr scale) nil +oci-attr-scale+ - (deref errhp)) - (cond - ((zerop scale) - (setf buffer (acquire-alien-resource signed +n-buf-rows+) - sizeof 4 ;; sizeof(int) - dtype #.SQLT-INT)) - (t - (setf buffer (acquire-alien-resource double-float +n-buf-rows+) - sizeof 8 ;; sizeof(double) - dtype #.SQLT-FLT)))) - (t ; Default to SQL-STR - (setf colsize 0 - dtype #.SQLT-STR) - (oci-attr-get parmdp +oci-dtype-param+ (addr colsize) - (addr colsizesize) +oci-attr-data-size+ - (deref errhp)) - (let ((colsize-including-null (1+ colsize))) - (setf buffer (acquire-alien-resource char (* +n-buf-rows+ colsize-including-null))) - (setf sizeof colsize-including-null)))) - (let ((retcodes (acquire-alien-resource short +n-buf-rows+)) - (indicators (acquire-alien-resource short +n-buf-rows+))) - (push (make-cd :name "col" ;(subseq colname 0 colnamelen) - :sizeof sizeof - :buffer buffer - :oci-data-type dtype - :retcodes retcodes - :indicators indicators) - cds-as-reversed-list) - (oci-define-by-pos (deref stmthp) - (addr defnp) - (deref errhp) - (1+ icolumn) ; OCI 1-based indexing again - (alien-resource-buffer buffer) - sizeof - dtype - (alien-resource-buffer indicators) - nil - (alien-resource-buffer retcodes) - +oci-default+))))))) - -;; Release the resources associated with a QUERY-CURSOR. - -(defun close-query (qc) - (oci-handle-free (deref (qc-stmthp qc)) +oci-htype-stmt+) - (let ((cds (qc-cds qc))) - (dotimes (i (length cds)) - (release-cd-resources (aref cds i)))) - (values)) - - -;; Release the resources associated with a column description. - -(defun release-cd-resources (cd) - (free-alien-resource (cd-buffer cd)) - (free-alien-resource (cd-retcodes cd)) - (free-alien-resource (cd-indicators cd)) - (values)) - - -(defmethod print-object ((db oracle-database) stream) - (print-unreadable-object (db stream :type t :identity t) - (format stream "\"/~a/~a\"" - (slot-value db 'data-source-name) - (slot-value db 'user)))) - - -(defmethod database-name-from-spec (connection-spec (database-type (eql :oracle))) - (check-connection-spec connection-spec database-type (user password dsn)) - (destructuring-bind (user password dsn) - connection-spec - (declare (ignore password)) - (concatenate 'string "/" dsn "/" user))) - - -(defmethod database-connect (connection-spec (database-type (eql :oracle))) - (check-connection-spec connection-spec database-type (user password dsn)) - (destructuring-bind (user password data-source-name) - connection-spec - (let ((envhp (make-alien (* t))) - (errhp (make-alien (* t))) - (svchp (make-alien (* t))) - (srvhp (make-alien (* t)))) - ;; Requests to allocate environments and handles should never - ;; fail in normal operation, and they're done too early to - ;; handle errors very gracefully (since they're part of the - ;; error-handling mechanism themselves) so we just assert they - ;; work. - (setf (deref envhp) nil) - #+oci-8-1-5 - (progn - (oci-env-create (c-& envhp) +oci-default+ nil nil nil nil 0 nil) - (oci-handle-alloc (deref envhp) (c-& errhp) +oci-htype-error+ 0 nil)) - #-oci-8-1-5 - (progn - (oci-initialize +oci-object+ nil nil nil nil) - (ignore-errors (oci-handle-alloc nil (c-& envhp) +oci-htype-env+ 0 nil)) ;no testing return - (oci-env-init (c-& envhp) +oci-default+ 0 nil) - (oci-handle-alloc (deref envhp) (c-& errhp) +oci-htype-error+ 0 nil) - (oci-handle-alloc (deref envhp) (c-& srvhp) +oci-htype-server+ 0 nil) - ;;(osucc (oci-server-attach srvhp errhp nil 0 +oci-default+)) - (oci-handle-alloc (deref envhp) (c-& svchp) +oci-htype-svcctx+ 0 nil) - ;; oci-handle-alloc((dvoid *)encvhp, (dvoid **)&stmthp, OCI_HTYPE_STMT, 0, 0); - #+nil - (oci-attr-set (deref svchp) +oci-htype-svcctx+ (deref srvhp) 0 +oci-attr-server+ errhp) - ) - - #+nil - (format t "Logging in as user '~A' to database ~A~%" - user password data-source-name) - (oci-logon (deref envhp) (deref errhp) (c-& svchp) - user (length user) - password (length password) - data-source-name (length data-source-name)) - (let ((db (make-instance 'oracle-database - :name (database-name-from-spec connection-spec - database-type) - :envhp envhp - :errhp errhp - :db-type :oracle - :svchp svchp - :dsn data-source-name - :user user))) - ;; :date-format-length (1+ (length date-format))))) - (sql:execute-command - (format nil "alter session set NLS_DATE_FORMAT='~A'" - (date-format db)) :database db) - db)))) - - -;; Close a database connection. - -(defmethod database-disconnect ((database oracle-database)) - (osucc (oci-logoff (deref (svchp database)) (deref (errhp database)))) - (osucc (oci-handle-free (deref (envhp database)) +oci-htype-env+)) - ;; Note: It's neither required nor allowed to explicitly deallocate the - ;; ERRHP handle here, since it's owned by the ENVHP deallocated above, - ;; and was therefore automatically deallocated at the same time. - t) - -;;; Do the database operation described in SQL-STMT-STRING on database -;;; DB and, if the command is a SELECT, return a representation of the -;;; resulting table. The representation of the table is controlled by the -;;; QUERY argument: -;;; * If QUERY is NIL, the table is returned as a list of rows, with -;;; each row represented by a list. -;;; * If QUERY is non-NIL, the result is returned as a QUERY-CURSOR -;;; suitable for FETCH-ROW and CLOSE-QUERY -;;; The TYPES argument controls the type conversion method used -;;; to construct the table. The Allegro version supports several possible -;;; values for this argument, but we only support :AUTO. - -(defmethod database-query (query-expression (database oracle-database)) - (let ((cursor (sql-stmt-exec query-expression database :types :auto))) - (declare (type (or query-cursor null) cursor)) - (if (null cursor) ; No table was returned. - (values) - (do ((reversed-result nil)) - (nil) - (let* ((eof-value :eof) - (row (fetch-row cursor nil eof-value))) - (when (eq row eof-value) - (close-query cursor) - (return (nreverse reversed-result))) - (push row reversed-result)))))) - - -(defmethod database-create-sequence - (sequence-name (database oracle-database)) - (execute-command - (concatenate 'string "CREATE SEQUENCE " - (sql-escape sequence-name)) - :database database)) - -(defmethod database-drop-sequence - (sequence-name (database oracle-database)) - (execute-command - (concatenate 'string "DROP SEQUENCE " - (sql-escape sequence-name)) - :database database)) - -(defmethod database-sequence-next (sequence-name (database oracle-database)) - (caar - (query - (concatenate 'string "SELECT " - (sql-escape sequence-name) - ".NEXTVAL FROM dual" - ) :database database))) - - -(defmethod database-execute-command - (sql-expression (database oracle-database)) - (database-query sql-expression database) - ;; HACK HACK HACK - (database-query "commit" database) - t) - - -;;; a column descriptor: metadata about the data in a table -(defstruct (cd (:constructor make-cd) - (:print-function print-cd)) - ;; name of this column - (name (error "missing NAME") :type simple-string :read-only t) - ;; the size in bytes of a single element - (sizeof (error "missing SIZE") :type fixnum :read-only t) - ;; an array of +N-BUF-ROWS+ elements in C representation - (buffer (error "Missing BUFFER") - :type alien-resource - :read-only t) - ;; an array of +N-BUF-ROWS+ OCI return codes in C representation. - ;; (There must be one return code for every element of every - ;; row in order to be able to represent nullness.) - (retcodes (error "Missing RETCODES") - :type alien-resource - :read-only t) - (indicators (error "Missing INDICATORS") - :type alien-resource - :read-only t) - ;; the OCI code for the data type of a single element - (oci-data-type (error "missing OCI-DATA-TYPE") - :type fixnum - :read-only t)) - - -(defun print-cd (cd stream depth) - (declare (ignore depth)) - (print-unreadable-object (cd stream :type t) - (format stream - ":NAME ~S :OCI-DATA-TYPE ~S :OCI-DATA-SIZE ~S" - (cd-name cd) - (cd-oci-data-type cd) - (cd-sizeof cd)))) - -;;; the result of a database query: a cursor through a table -(defstruct (oracle-result-set (:print-function print-query-cursor) - (:conc-name "QC-") - (:constructor %make-query-cursor)) - (db (error "missing DB") ; db conn. this table is associated with - :type db - :read-only t) - (stmthp (error "missing STMTHP") ; the statement handle used to create - :type alien ; this table. owned by the QUERY-CURSOR - :read-only t) ; object, deallocated on CLOSE-QUERY - (cds) ; (error "missing CDS") ; column descriptors -; :type (simple-array cd 1) -; :read-only t) - (n-from-oci 0 ; buffered rows: number of rows recv'd - :type (integer 0 #.+n-buf-rows+)) ; from the database on the last read - (n-to-dbi 0 ; number of buffered rows returned, i.e. - :type (integer 0 #.+n-buf-rows+)) ; the index, within the buffered rows, - ; of the next row which hasn't already - ; been returned - (total-n-from-oci 0 ; total number of bytes recv'd from OCI - :type unsigned-byte) ; in all reads - (oci-end-seen-p nil)) ; Have we seen the end of OCI - ; data, i.e. OCI returning - ; less data than we requested? - ; OCI doesn't seem to like us - ; to try to read more data - ; from it after that.. - -(defun print-query-cursor (qc stream depth) - (declare (ignore depth)) - (print-unreadable-object (qc stream :type t :identity t) - (prin1 (qc-db qc) stream))) - - -(defmethod database-query-result-set (query-expression (database oracle-database) &optional full-set) - ) - -(defmethod database-dump-result-set (result-set (database oracle-database)) - ) - -(defmethod database-store-next-row (result-set (database oracle-database) list) - ) - -(defmethod sql-sys::database-start-transaction ((database oracle-database)) - (call-next-method)) - -;;(with-slots (svchp errhp) database -;; (osucc (oci-trans-start (deref svchp) -;; (deref errhp) -;; 60 -;; +oci-trans-new+))) -;; t) - - -(defmethod sql-sys::database-commit-transaction ((database oracle-database)) - (call-next-method) - (with-slots (svchp errhp) database - (osucc (oci-trans-commit (deref svchp) - (deref errhp) - 0))) - t) - -(defmethod sql-sys::database-abort-transaction ((database oracle-database)) - (call-next-method) - (osucc (oci-trans-rollback (deref (svchp database)) - (deref (errhp database)) - 0)) - t) - -(defparameter *constraint-types* - '(("NOT-NULL" . "NOT NULL"))) - -(defmethod database-output-sql ((str string) (database oracle-database)) - (if (and (null (position #\' str)) - (null (position #\\ str))) - (format nil "'~A'" str) - (let* ((l (length str)) - (buf (make-string (+ l 3)))) - (setf (aref buf 0) #\') - (do ((i 0 (incf i)) - (j 1 (incf j))) - ((= i l) (setf (aref buf j) #\')) - (if (= j (- (length buf) 1)) - (setf buf (adjust-array buf (+ (length buf) 1)))) - (cond ((eql (aref str i) #\') - (setf (aref buf j) #\') - (incf j))) - (setf (aref buf j) (aref str i))) - buf))) - - diff --git a/db-oracle/oracle-sql.lisp b/db-oracle/oracle-sql.lisp new file mode 100644 index 0000000..072465e --- /dev/null +++ b/db-oracle/oracle-sql.lisp @@ -0,0 +1,856 @@ +;;; -*- Mode: Lisp -*- +;;; $Id: oracle-sql.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $ + +;;; MaiSQL --- Common Lisp Interface Layer to SQL Databases +;;; This is copyrighted software. See documentation for terms. +;;; +;;; oracle-sql.lisp --- SQL-Interface implementation for Oracle +;;; +;;; derived from postgresql.lisp + +(in-package :clsql-oracle) + +(defmethod database-initialize-database-type + ((database-type (eql :oracle))) + t) + +;;;; KLUDGE: The original prototype of this code was implemented using +;;;; lots of special variables holding MAKE-ALIEN values. When I was +;;;; first converting it to use WITH-ALIEN variables, I was confused +;;;; about the behavior of MAKE-ALIEN and WITH-ALIEN; I thought that +;;;; (MAKE-ALIEN TYPEFOO) returned the same type of object as is bound +;;;; to the name BAR by (WITH-ALIEN ((BAR TYPEFOO)) ..). In fact the +;;;; value returned by MAKE-ALIEN has an extra level of indirection +;;;; relative to the value bound by WITH-ALIEN, i.e. (DEREF +;;;; (MAKE-ALIEN TYPEFOO)) has the same type as the value bound to the +;;;; name BAR by (WITH-ALIEN ((BAR TYPEFOO)) ..). Laboring under my +;;;; misunderstanding, I was unable to use ordinary scalars bound by +;;;; WITH-ALIEN, and I ended up giving up and deciding to work around +;;;; this apparent bug in CMUCL by using 1-element arrays instead. +;;;; This "workaround" for my misunderstanding is obviously unnecessary +;;;; and confusing, but still remains in the code. -- WHN 20000106 + + +;;;; arbitrary parameters, tunable for performance or other reasons + +;;; the number of table rows that we buffer at once when reading a table +;;; +;;; CMUCL has a compiled-in limit on how much C data can be allocated +;;; (through malloc() and friends) at any given time, typically 8 Mb. +;;; Setting this constant to a moderate value should make it less +;;; likely that we'll have to worry about the CMUCL limit. +(defconstant +n-buf-rows+ 200) +;;; the number of characters that we allocate for an error message buffer +(defconstant +errbuf-len+ 512) + +;;; utilities for mucking around with C-level stuff + +;; Return the address of ALIEN-OBJECT (like the C operator "&"). +;; +;; The INDICES argument is useful to give the ALIEN-OBJECT the +;; expected number of zero indices, especially when we have a bunch of +;; 1-element arrays running around due to the workaround for the CMUCL +;; 18b WITH-ALIEN scalar bug. + +(defmacro c-& (alien-object &rest indices) + `(addr (deref ,alien-object ,@indices))) + +;; constants - from OCI? + +(defconstant +var-not-in-list+ 1007) +(defconstant +no-data-found+ 1403) +(defconstant +null-value-returned+ 1405) +(defconstant +field-truncated+ 1406) + +(defconstant SQLT-INT 3) +(defconstant SQLT-STR 5) +(defconstant SQLT-FLT 4) +(defconstant SQLT-DATE 12) + +;;; Note that despite the suggestive class name (and the way that the +;;; *DEFAULT-DATABASE* variable holds an object of this class), a DB +;;; object is not actually a database but is instead a connection to a +;;; database. Thus, there's no obstacle to having any number of DB +;;; objects referring to the same database. + +(defclass oracle-database (database) ; was struct db + ((envhp + :reader envhp + :initarg :envhp + :type (alien (* (* t))) + :documentation + "OCI environment handle") + (errhp + :reader errhp + :initarg :errhp + :type (alien (* (* t))) + :documentation + "OCI error handle") + (svchp + :reader svchp + :initarg :svchp + :type (alien (* (* t))) + :documentation + "OCI service context handle") + (data-source-name + :initarg :dsn + :initform nil + :documentation + "optional data source name (used only for debugging/printing)") + (user + :initarg :user + :reader user + :type string + :documentation + "the \"user\" value given when data source connection was made") + (date-format + :initarg :date-format + :reader date-format + :initform "YYYY-MM-DD HH24:MI:SS\"+00\"") + (date-format-length + :type number + :documentation + "Each database connection can be configured with its own date +output format. In order to extract date strings from output buffers +holding multiple date strings in fixed-width fields, we need to know +the length of that format."))) + + +;;; Handle the messy case of return code=+oci-error+, querying the +;;; system for subcodes and reporting them as appropriate. ERRHP and +;;; NULLS-OK are as in the OERR function. + +(defun handle-oci-error (&key database nulls-ok) + (cond (database + (with-slots (errhp) + database + (with-alien ((errbuf (array char #.+errbuf-len+)) + (errcode (array long 1))) + (setf (deref errbuf 0) 0) ; i.e. init to empty string + (setf (deref errcode 0) 0) + (oci-error-get (deref errhp) 1 "" (c-& errcode 0) (c-& errbuf 0) +errbuf-len+ +oci-htype-error+) + (let ((subcode (deref errcode 0))) + (unless (and nulls-ok (= subcode +null-value-returned+)) + (error 'clsql-sql-error + :database database + :errno subcode + :error (cast (c-& errbuf 0) c-string))))))) + (nulls-ok + (error 'clsql-sql-error + :database database + :error "can't handle NULLS-OK without ERRHP")) + (t + (error 'clsql-sql-error + :database database + :error "OCI Error (and no ERRHP available to find subcode)")))) + +;;; Require an OCI success code. +;;; +;;; (The ordinary OCI error reporting mechanisms uses a fair amount of +;;; machinery (environments and other handles). In order to get to +;;; where we can use these mechanisms, we have to be able to allocate +;;; the machinery. The functions for allocating the machinery can +;;; return errors (e.g. out of memory) but shouldn't. Wrapping this function +;;; around function calls to such have-to-succeed functions enforces +;;; this condition.) + +(defun osucc (code) + (declare (type fixnum code)) + (unless (= code +oci-success+) + (error 'dbi-error + :format-control "unexpected OCI failure, code=~S" + :format-arguments (list code)))) + + +;;; Enabling this can be handy for low-level debugging. +#+nil +(progn + (trace oci-initialize #+oci-8-1-5 oci-env-create oci-handle-alloc oci-logon + oci-error-get oci-stmt-prepare oci-stmt-execute + oci-param-get oci-logon oci-attr-get oci-define-by-pos oci-stmt-fetch) + (setf debug::*debug-print-length* nil)) + + +;;;; the OCI library, part V: converting from OCI representations to Lisp +;;;; representations + +;; Return the INDEXth string of the OCI array, represented as Lisp +;; SIMPLE-STRING. SIZE is the size of the fixed-width fields used by +;; Oracle to store strings within the array. + +;; In the wild world of databases, trailing spaces aren't generally +;; significant, since e.g. "LARRY " and "LARRY " are the same string +;; stored in different fixed-width fields. OCI drops trailing spaces +;; for us in some cases but apparently not for fields of fixed +;; character width, e.g. +;; +;; (dbi:sql "create table employees (name char(15), job char(15), city +;; char(15), rate float)" :db orcl :types :auto) +;; In order to map the "same string" property above onto Lisp equality, +;; we drop trailing spaces in all cases: + +(defun deref-oci-string (arrayptr string-index size) + (declare (type (alien (* char)) arrayptr)) + (declare (type (mod #.+n-buf-rows+) string-index)) + (declare (type (and unsigned-byte fixnum) size)) + (let* ((raw (cast (addr (deref arrayptr (* string-index size))) c-string)) + (trimmed (string-trim " " raw))) + (if (equal trimmed "NULL") nil trimmed))) + +;; the OCI library, part Z: no-longer used logic to convert from +;; Oracle's binary date representation to Common Lisp's native date +;; representation + +#+nil +(defvar +oci-date-bytes+ 7) + +;;; Return the INDEXth date in the OCI array, represented as +;;; a Common Lisp "universal time" (i.e. seconds since 1900). + +#+nil +(defun deref-oci-date (arrayptr index) + (oci-date->universal-time (addr (deref arrayptr + (* index +oci-date-bytes+))))) +#+nil +(defun oci-date->universal-time (oci-date) + (declare (type (alien (* char)) oci-date)) + (flet (;; a character from OCI-DATE, interpreted as an unsigned byte + (ub (i) + (declare (type (mod #.+oci-date-bytes+) i)) + (mod (deref oci-date i) 256))) + (let* ((century (* (- (ub 0) 100) 100)) + (year (+ century (- (ub 1) 100))) + (month (ub 2)) + (day (ub 3)) + (hour (1- (ub 4))) + (minute (1- (ub 5))) + (second (1- (ub 6)))) + (encode-universal-time second minute hour day month year)))) + +;; Return (VALUES ALL-TABLES COLUMN-NAMES), where ALL-TABLES is a +;; table containing one row for each table available in DB, and +;; COLUMN-NAMES is a list of header names for the columns in +;; ALL-TABLES. +;; +;; The Allegro version also accepted a HSTMT argument. + +;(defmethod database-list-tables ((db oracle-database)) +; (sql:query "select '',OWNER,TABLE_NAME,TABLE_TYPE,'' from all_catalog")) + + +(defmethod list-all-user-database-tables ((db oracle-database)) + (unless db + (setf db sql:*default-database*)) + (values (database-query "select TABLE_NAME from all_catalog + where owner <> 'PUBLIC' and owner <> 'SYSTEM' and owner <> 'SYS'" + db))) + + +(defmethod database-list-tables ((database oracle-database) + &key (system-tables nil)) + (if system-tables + (select [table_name] :from [all_catalog]) + (select [table_name] :from [all_catalog] + :where [and [<> [owner] "PUBLIC"] + [<> [owner] "SYSTEM"] + [<> [owner] "SYS"]] + :flatp t))) + +;; Return a list of all columns in TABLE. +;; +;; The Allegro version of this also returned a second value. + +(defmethod list-all-table-columns (table (db oracle-database)) + (declare (type string table)) + (unless db + (setf db (default-database))) + (let* ((sql-stmt (concatenate + 'simple-string + "select " + "''," + "all_tables.OWNER," + "''," + "user_tab_columns.COLUMN_NAME," + "user_tab_columns.DATA_TYPE from user_tab_columns," + "all_tables where all_tables.table_name = '" table "'" + " and user_tab_columns.table_name = '" table "'")) + (preresult (sql sql-stmt :db db :types :auto))) + ;; PRERESULT is like RESULT except that it has a name instead of + ;; type codes in the fifth column of each row. To fix this, we + ;; destructively modify PRERESULT. + (dolist (preresult-row preresult) + (setf (fifth preresult-row) + (if (find (fifth preresult-row) + #("NUMBER" "DATE") + :test #'string=) + 2 ; numeric + 1))) ; string + preresult)) + +(defmethod database-list-attributes (table (database oracle-database)) + (let* ((relname (etypecase table + (sql-sys::sql-ident + (string-upcase + (symbol-name (slot-value table 'sql-sys::name)))) + (string table)))) + (select [user_tab_columns column_name] + :from [user_tab_columns] + :where [= [user_tab_columns table_name] relname] + :flatp t))) + + + +;; Return one row of the table referred to by QC, represented as a +;; list; or if there are no more rows, signal an error if EOF-ERRORP, +;; or return EOF-VALUE otherwise. + +;; KLUDGE: This CASE statement is a strong sign that the code would be +;; cleaner if CD were made into an abstract class, we made variant +;; classes for CD-for-column-of-strings, CD-for-column-of-floats, +;; etc., and defined virtual functions to handle operations like +;; get-an-element-from-column. (For a small special purpose module +;; like this, would arguably be overkill, so I'm not going to do it +;; now, but if this code ends up getting more complicated in +;; maintenance, it would become a really good idea.) + +;; Arguably this would be a good place to signal END-OF-FILE, but +;; since the ANSI spec specifically says that END-OF-FILE means a +;; STREAM which has no more data, and QC is not a STREAM, we signal +;; DBI-ERROR instead. + +(defun fetch-row (qc &optional (eof-errorp t) eof-value) + (declare (optimize (speed 3))) + (cond ((zerop (qc-n-from-oci qc)) + (if eof-errorp + (dbi-error "no more rows available in ~S" qc) + eof-value)) + ((>= (qc-n-to-dbi qc) + (qc-n-from-oci qc)) + (refill-qc-buffers qc) + (fetch-row qc nil eof-value)) + (t + (let ((cds (qc-cds qc)) + (reversed-result nil) + (irow (qc-n-to-dbi qc))) + (dotimes (icd (length cds)) + (let* ((cd (aref cds icd)) + (b (alien-resource-buffer (cd-buffer cd))) + (value + (let ((arb (alien-resource-buffer (cd-indicators cd)))) + (declare (type (alien (* (alien:signed 16))) arb)) + (unless (= (deref arb irow) -1) + (ecase (cd-oci-data-type cd) + (#.SQLT-STR (deref-oci-string b irow (cd-sizeof cd))) + (#.SQLT-FLT (deref (the (alien (* double)) b) irow)) + (#.SQLT-INT (deref (the (alien (* int)) b) irow)) + (#.SQLT-DATE (deref-oci-string b irow (cd-sizeof cd)))))))) + (push value reversed-result))) + (incf (qc-n-to-dbi qc)) + (nreverse reversed-result))))) + +(defun refill-qc-buffers (qc) + (with-slots (errhp) + (qc-db qc) + (setf (qc-n-to-dbi qc) 0) + (cond ((qc-oci-end-seen-p qc) + (setf (qc-n-from-oci qc) 0)) + (t + (let ((oci-code (%oci-stmt-fetch (deref (qc-stmthp qc)) + (deref errhp) + +n-buf-rows+ + +oci-fetch-next+ +oci-default+))) + (ecase oci-code + (#.+oci-success+ (values)) + (#.+oci-no-data+ (setf (qc-oci-end-seen-p qc) t) + (values)) + (#.+oci-error+ (handle-oci-error :database (qc-db qc) + :nulls-ok t)))) + (with-alien ((rowcount (array unsigned-long 1))) + (oci-attr-get (deref (qc-stmthp qc)) +oci-htype-stmt+ + (c-& rowcount 0) nil +oci-attr-row-count+ + (deref errhp)) + (setf (qc-n-from-oci qc) + (- (deref rowcount 0) (qc-total-n-from-oci qc))) + (when (< (qc-n-from-oci qc) +n-buf-rows+) + (setf (qc-oci-end-seen-p qc) t)) + (setf (qc-total-n-from-oci qc) + (deref rowcount 0))))) + (values))) + +;; the guts of the SQL function +;; +;; (like the SQL function, but with the QUERY argument hardwired to T, so +;; that the return value is always a cursor instead of a list) + +;; Is this a SELECT statement? SELECT statements are handled +;; specially by OCIStmtExecute(). (Non-SELECT statements absolutely +;; require a nonzero iteration count, while the ordinary choice for a +;; SELECT statement is a zero iteration count. + +;; SELECT statements are the only statements which return tables. We +;; don't free STMTHP in this case, but instead give it to the new +;; QUERY-CURSOR, and the new QUERY-CURSOR becomes responsible for +;; freeing the STMTHP when it is no longer needed. + +(defun sql-stmt-exec (sql-stmt-string db &key types) + (with-slots (envhp svchp errhp) + db + (let ((stmthp (make-alien (* t)))) + (with-alien ((stmttype (array unsigned-short 1))) + + (oci-handle-alloc (deref envhp) (c-& stmthp) +oci-htype-stmt+ 0 nil) + (oci-stmt-prepare (deref stmthp) (deref errhp) + sql-stmt-string (length sql-stmt-string) + +oci-ntv-syntax+ +oci-default+ :database db) + (oci-attr-get (deref stmthp) +oci-htype-stmt+ + (c-& stmttype 0) nil +oci-attr-stmt-type+ + (deref errhp) :database db) + (let* ((select-p (= (deref stmttype 0) 1)) + (iters (if select-p 0 1))) + + (oci-stmt-execute (deref svchp) (deref stmthp) (deref errhp) + iters 0 nil nil +oci-default+ :database db) + (cond (select-p + (make-query-cursor db stmthp types)) + (t + (oci-handle-free (deref stmthp) +oci-htype-stmt+) + nil))))))) + + +;; Return a QUERY-CURSOR representing the table returned from the OCI +;; operation done through STMTHP. TYPES is the argument of the same +;; name from the external SQL function, controlling type conversion +;; of the returned arguments. + +(defun make-query-cursor (db stmthp types) + (let ((qc (%make-query-cursor :db db + :stmthp stmthp + :cds (make-query-cursor-cds db stmthp types)))) + (refill-qc-buffers qc) + qc)) + + +;; the hairy part of MAKE-QUERY-CURSOR: Ask OCI for information +;; about table columns, translate the information into a Lisp +;; vector of column descriptors, and return it. + +;; Allegro defines several flavors of type conversion, but this +;; implementation only supports the :AUTO flavor. + +;; A note of explanation: OCI's internal number format uses 21 +;; bytes (42 decimal digits). 2 separate (?) one-byte fields, +;; scale and precision, are used to deduce the nature of these +;; 21 bytes. See pp. 3-10, 3-26, and 6-13 of OCI documentation +;; for more details. + +;; When calling OCI C code to handle the conversion, we have +;; only two numeric types available to pass the return value: +;; double-float and signed-long. It would be possible to +;; bypass the OCI conversion functions and write Lisp code +;; which reads the 21-byte field directly and decodes +;; it. However this is left as an exercise for the reader. :-) + +;; The following table describes the mapping, based on the implicit +;; assumption that C's "signed long" type is a 32-bit integer. +;; +;; Internal Values SQL Type C Return Type +;; =============== ======== ============= +;; Precision > 0 SCALE = -127 FLOAT --> double-float +;; Precision > 0 && <=9 SCALE = 0 INTEGER --> signed-long +;; Precision = 0 || > 9 SCALE = 0 BIG INTEGER --> double-float +;; Precision > 0 SCALE > 0 DECIMAL --> double-float + +;; (OCI uses 1-based indexing here.) + +;; KLUDGE: This should work for all other data types except those +;; which don't actually fit in their fixed-width field (BLOBs and the +;; like). As Winton says, we (Cadabra) don't need to worry much about +;; those, since we can't reason with them, so we don't use them. But +;; for a more general application it'd be good to have a more +;; selective and rigorously correct test here for whether we can +;; actually handle the given DEREF-DTYPE value. -- WHN 20000106 + +;; Note: The OCI documentation doesn't seem to say whether the COLNAME +;; value returned here is a newly-allocated copy which we're +;; responsible for freeing, or a pointer into some system copy which +;; will be freed when the system itself is shut down. But judging +;; from the way that the result is used in the cdemodsa.c example +;; program, it looks like the latter: we should make our own copy of +;; the value, but not try to free it. + +;; WORKAROUND: OCI seems to return ub2 values for the +;; +oci-attr-data-size+ attribute even though its documentation claims +;; that it returns a ub4, and even though the associated "sizep" value +;; is 4, not 2. In order to make the code here work reliably, without +;; having to patch it later if OCI is ever fixed to match its +;; documentation, we pre-zero COLSIZE before making the call into OCI. + +;; To exercise the weird OCI behavior (thereby blowing up the code +;; below, beware!) try setting this value into COLSIZE, calling OCI, +;; then looking at the value in COLSIZE. (setf colsize #x12345678) +;; debugging only + + +(defun make-query-cursor-cds (database stmthp types) + (declare (optimize (speed 3)) + (type oracle-database database) + (type (alien (* (* t))) stmthp)) + (with-slots (errhp) + database + (unless (eq types :auto) + (error "unsupported TYPES value")) + (with-alien ((dtype unsigned-short 1) + (parmdp (* t)) + (precision (unsigned 8)) + (scale (signed 8)) + (colname c-string) + (colnamelen unsigned-long) + (colsize unsigned-long) + (colsizesize unsigned-long) + (defnp (* t))) + (let ((buffer nil) + (sizeof nil)) + (do ((icolumn 0 (1+ icolumn)) + (cds-as-reversed-list nil)) + ((not (eql (oci-param-get (deref stmthp) +oci-htype-stmt+ + (deref errhp) (addr parmdp) + (1+ icolumn) :database database) + +oci-success+)) + (coerce (reverse cds-as-reversed-list) 'simple-vector)) + ;; Decode type of ICOLUMNth column into a type we're prepared to + ;; handle in Lisp. + (oci-attr-get parmdp +oci-dtype-param+ (addr dtype) + nil +oci-attr-data-type+ (deref errhp)) + (case dtype + (#.SQLT-DATE + (setf buffer (acquire-alien-resource char (* 32 +n-buf-rows+))) + (setf sizeof 32 dtype #.SQLT-STR)) + (2 ;; number + ;;(oci-attr-get parmdp +oci-dtype-param+ + ;;(addr precision) nil +oci-attr-precision+ + ;;(deref errhp)) + (oci-attr-get parmdp +oci-dtype-param+ + (addr scale) nil +oci-attr-scale+ + (deref errhp)) + (cond + ((zerop scale) + (setf buffer (acquire-alien-resource signed +n-buf-rows+) + sizeof 4 ;; sizeof(int) + dtype #.SQLT-INT)) + (t + (setf buffer (acquire-alien-resource double-float +n-buf-rows+) + sizeof 8 ;; sizeof(double) + dtype #.SQLT-FLT)))) + (t ; Default to SQL-STR + (setf colsize 0 + dtype #.SQLT-STR) + (oci-attr-get parmdp +oci-dtype-param+ (addr colsize) + (addr colsizesize) +oci-attr-data-size+ + (deref errhp)) + (let ((colsize-including-null (1+ colsize))) + (setf buffer (acquire-alien-resource char (* +n-buf-rows+ colsize-including-null))) + (setf sizeof colsize-including-null)))) + (let ((retcodes (acquire-alien-resource short +n-buf-rows+)) + (indicators (acquire-alien-resource short +n-buf-rows+))) + (push (make-cd :name "col" ;(subseq colname 0 colnamelen) + :sizeof sizeof + :buffer buffer + :oci-data-type dtype + :retcodes retcodes + :indicators indicators) + cds-as-reversed-list) + (oci-define-by-pos (deref stmthp) + (addr defnp) + (deref errhp) + (1+ icolumn) ; OCI 1-based indexing again + (alien-resource-buffer buffer) + sizeof + dtype + (alien-resource-buffer indicators) + nil + (alien-resource-buffer retcodes) + +oci-default+))))))) + +;; Release the resources associated with a QUERY-CURSOR. + +(defun close-query (qc) + (oci-handle-free (deref (qc-stmthp qc)) +oci-htype-stmt+) + (let ((cds (qc-cds qc))) + (dotimes (i (length cds)) + (release-cd-resources (aref cds i)))) + (values)) + + +;; Release the resources associated with a column description. + +(defun release-cd-resources (cd) + (free-alien-resource (cd-buffer cd)) + (free-alien-resource (cd-retcodes cd)) + (free-alien-resource (cd-indicators cd)) + (values)) + + +(defmethod print-object ((db oracle-database) stream) + (print-unreadable-object (db stream :type t :identity t) + (format stream "\"/~a/~a\"" + (slot-value db 'data-source-name) + (slot-value db 'user)))) + + +(defmethod database-name-from-spec (connection-spec (database-type (eql :oracle))) + (check-connection-spec connection-spec database-type (user password dsn)) + (destructuring-bind (user password dsn) + connection-spec + (declare (ignore password)) + (concatenate 'string "/" dsn "/" user))) + + +(defmethod database-connect (connection-spec (database-type (eql :oracle))) + (check-connection-spec connection-spec database-type (user password dsn)) + (destructuring-bind (user password data-source-name) + connection-spec + (let ((envhp (make-alien (* t))) + (errhp (make-alien (* t))) + (svchp (make-alien (* t))) + (srvhp (make-alien (* t)))) + ;; Requests to allocate environments and handles should never + ;; fail in normal operation, and they're done too early to + ;; handle errors very gracefully (since they're part of the + ;; error-handling mechanism themselves) so we just assert they + ;; work. + (setf (deref envhp) nil) + #+oci-8-1-5 + (progn + (oci-env-create (c-& envhp) +oci-default+ nil nil nil nil 0 nil) + (oci-handle-alloc (deref envhp) (c-& errhp) +oci-htype-error+ 0 nil)) + #-oci-8-1-5 + (progn + (oci-initialize +oci-object+ nil nil nil nil) + (ignore-errors (oci-handle-alloc nil (c-& envhp) +oci-htype-env+ 0 nil)) ;no testing return + (oci-env-init (c-& envhp) +oci-default+ 0 nil) + (oci-handle-alloc (deref envhp) (c-& errhp) +oci-htype-error+ 0 nil) + (oci-handle-alloc (deref envhp) (c-& srvhp) +oci-htype-server+ 0 nil) + ;;(osucc (oci-server-attach srvhp errhp nil 0 +oci-default+)) + (oci-handle-alloc (deref envhp) (c-& svchp) +oci-htype-svcctx+ 0 nil) + ;; oci-handle-alloc((dvoid *)encvhp, (dvoid **)&stmthp, OCI_HTYPE_STMT, 0, 0); + #+nil + (oci-attr-set (deref svchp) +oci-htype-svcctx+ (deref srvhp) 0 +oci-attr-server+ errhp) + ) + + #+nil + (format t "Logging in as user '~A' to database ~A~%" + user password data-source-name) + (oci-logon (deref envhp) (deref errhp) (c-& svchp) + user (length user) + password (length password) + data-source-name (length data-source-name)) + (let ((db (make-instance 'oracle-database + :name (database-name-from-spec connection-spec + database-type) + :envhp envhp + :errhp errhp + :db-type :oracle + :svchp svchp + :dsn data-source-name + :user user))) + ;; :date-format-length (1+ (length date-format))))) + (sql:execute-command + (format nil "alter session set NLS_DATE_FORMAT='~A'" + (date-format db)) :database db) + db)))) + + +;; Close a database connection. + +(defmethod database-disconnect ((database oracle-database)) + (osucc (oci-logoff (deref (svchp database)) (deref (errhp database)))) + (osucc (oci-handle-free (deref (envhp database)) +oci-htype-env+)) + ;; Note: It's neither required nor allowed to explicitly deallocate the + ;; ERRHP handle here, since it's owned by the ENVHP deallocated above, + ;; and was therefore automatically deallocated at the same time. + t) + +;;; Do the database operation described in SQL-STMT-STRING on database +;;; DB and, if the command is a SELECT, return a representation of the +;;; resulting table. The representation of the table is controlled by the +;;; QUERY argument: +;;; * If QUERY is NIL, the table is returned as a list of rows, with +;;; each row represented by a list. +;;; * If QUERY is non-NIL, the result is returned as a QUERY-CURSOR +;;; suitable for FETCH-ROW and CLOSE-QUERY +;;; The TYPES argument controls the type conversion method used +;;; to construct the table. The Allegro version supports several possible +;;; values for this argument, but we only support :AUTO. + +(defmethod database-query (query-expression (database oracle-database)) + (let ((cursor (sql-stmt-exec query-expression database :types :auto))) + (declare (type (or query-cursor null) cursor)) + (if (null cursor) ; No table was returned. + (values) + (do ((reversed-result nil)) + (nil) + (let* ((eof-value :eof) + (row (fetch-row cursor nil eof-value))) + (when (eq row eof-value) + (close-query cursor) + (return (nreverse reversed-result))) + (push row reversed-result)))))) + + +(defmethod database-create-sequence + (sequence-name (database oracle-database)) + (execute-command + (concatenate 'string "CREATE SEQUENCE " + (sql-escape sequence-name)) + :database database)) + +(defmethod database-drop-sequence + (sequence-name (database oracle-database)) + (execute-command + (concatenate 'string "DROP SEQUENCE " + (sql-escape sequence-name)) + :database database)) + +(defmethod database-sequence-next (sequence-name (database oracle-database)) + (caar + (query + (concatenate 'string "SELECT " + (sql-escape sequence-name) + ".NEXTVAL FROM dual" + ) :database database))) + + +(defmethod database-execute-command + (sql-expression (database oracle-database)) + (database-query sql-expression database) + ;; HACK HACK HACK + (database-query "commit" database) + t) + + +;;; a column descriptor: metadata about the data in a table +(defstruct (cd (:constructor make-cd) + (:print-function print-cd)) + ;; name of this column + (name (error "missing NAME") :type simple-string :read-only t) + ;; the size in bytes of a single element + (sizeof (error "missing SIZE") :type fixnum :read-only t) + ;; an array of +N-BUF-ROWS+ elements in C representation + (buffer (error "Missing BUFFER") + :type alien-resource + :read-only t) + ;; an array of +N-BUF-ROWS+ OCI return codes in C representation. + ;; (There must be one return code for every element of every + ;; row in order to be able to represent nullness.) + (retcodes (error "Missing RETCODES") + :type alien-resource + :read-only t) + (indicators (error "Missing INDICATORS") + :type alien-resource + :read-only t) + ;; the OCI code for the data type of a single element + (oci-data-type (error "missing OCI-DATA-TYPE") + :type fixnum + :read-only t)) + + +(defun print-cd (cd stream depth) + (declare (ignore depth)) + (print-unreadable-object (cd stream :type t) + (format stream + ":NAME ~S :OCI-DATA-TYPE ~S :OCI-DATA-SIZE ~S" + (cd-name cd) + (cd-oci-data-type cd) + (cd-sizeof cd)))) + +;;; the result of a database query: a cursor through a table +(defstruct (oracle-result-set (:print-function print-query-cursor) + (:conc-name "QC-") + (:constructor %make-query-cursor)) + (db (error "missing DB") ; db conn. this table is associated with + :type db + :read-only t) + (stmthp (error "missing STMTHP") ; the statement handle used to create + :type alien ; this table. owned by the QUERY-CURSOR + :read-only t) ; object, deallocated on CLOSE-QUERY + (cds) ; (error "missing CDS") ; column descriptors +; :type (simple-array cd 1) +; :read-only t) + (n-from-oci 0 ; buffered rows: number of rows recv'd + :type (integer 0 #.+n-buf-rows+)) ; from the database on the last read + (n-to-dbi 0 ; number of buffered rows returned, i.e. + :type (integer 0 #.+n-buf-rows+)) ; the index, within the buffered rows, + ; of the next row which hasn't already + ; been returned + (total-n-from-oci 0 ; total number of bytes recv'd from OCI + :type unsigned-byte) ; in all reads + (oci-end-seen-p nil)) ; Have we seen the end of OCI + ; data, i.e. OCI returning + ; less data than we requested? + ; OCI doesn't seem to like us + ; to try to read more data + ; from it after that.. + +(defun print-query-cursor (qc stream depth) + (declare (ignore depth)) + (print-unreadable-object (qc stream :type t :identity t) + (prin1 (qc-db qc) stream))) + + +(defmethod database-query-result-set (query-expression (database oracle-database) &optional full-set) + ) + +(defmethod database-dump-result-set (result-set (database oracle-database)) + ) + +(defmethod database-store-next-row (result-set (database oracle-database) list) + ) + +(defmethod sql-sys::database-start-transaction ((database oracle-database)) + (call-next-method)) + +;;(with-slots (svchp errhp) database +;; (osucc (oci-trans-start (deref svchp) +;; (deref errhp) +;; 60 +;; +oci-trans-new+))) +;; t) + + +(defmethod sql-sys::database-commit-transaction ((database oracle-database)) + (call-next-method) + (with-slots (svchp errhp) database + (osucc (oci-trans-commit (deref svchp) + (deref errhp) + 0))) + t) + +(defmethod sql-sys::database-abort-transaction ((database oracle-database)) + (call-next-method) + (osucc (oci-trans-rollback (deref (svchp database)) + (deref (errhp database)) + 0)) + t) + +(defparameter *constraint-types* + '(("NOT-NULL" . "NOT NULL"))) + +(defmethod database-output-sql ((str string) (database oracle-database)) + (if (and (null (position #\' str)) + (null (position #\\ str))) + (format nil "'~A'" str) + (let* ((l (length str)) + (buf (make-string (+ l 3)))) + (setf (aref buf 0) #\') + (do ((i 0 (incf i)) + (j 1 (incf j))) + ((= i l) (setf (aref buf j) #\')) + (if (= j (- (length buf) 1)) + (setf buf (adjust-array buf (+ (length buf) 1)))) + (cond ((eql (aref str i) #\') + (setf (aref buf j) #\') + (incf j))) + (setf (aref buf j) (aref str i))) + buf))) + + diff --git a/db-oracle/oracle.cl b/db-oracle/oracle.cl deleted file mode 100644 index bde69eb..0000000 --- a/db-oracle/oracle.cl +++ /dev/null @@ -1,318 +0,0 @@ -;;; -*- Mode: Lisp -*- -;;; $Id: oracle.cl,v 1.1 2002/09/18 07:43:41 kevin Exp $ - -;;; MaiSQL --- Common Lisp Interface Layer to SQL Databases -;;; This is copyrighted software. See documentation for terms. -;;; -;;; oracle.lisp --- FFI interface to Oracle on Unix -;;; -;;; The present content of this file is orented specifically towards -;;; Oracle 8.0.5.1 under Linux, linking against libclntsh.so - -(in-package :clsql-oracle) - -;; - -(defvar *oci-initialized* nil) - -(defvar *oci-env* nil) - - -;; -;; Opaque pointer types -;; - -(def-alien-type oci-env (* t)) - -(def-alien-type oci-server (* t)) - -(def-alien-type oci-error (* t)) - -(def-alien-type oci-svc-ctx (* t)) - -(def-alien-type oci-stmt (* t)) - - -(defvar *oci-handle-types* - '(:error ; error report handle (OCIError) - :service-context ; service context handle (OCISvcCtx) - :statement ; statement (application request) handle (OCIStmt) - :describe ; select list description handle (OCIDescribe) - :server ; server context handle (OCIServer) - :session ; user session handle (OCISession) - :transaction ; transaction context handle (OCITrans) - :complex-object ; complex object retrieval handle (OCIComplexObject) - :security)) ; security handle (OCISecurity) - -(defstruct oci-handle - (type :unknown) - (pointer (make-alien (* t)))) - -(defun oci-init (&key (mode +oci-default+)) - (let ((x (alien-funcall (extern-alien "OCIInitialize" (function int int (* t) (* t) (* t) (* t))) - mode nil nil nil nil))) - (if (= x 0) - (let ((env (make-alien oci-env))) - (setq *oci-initialized* mode) - (let ((x (alien-funcall (extern-alien "OCIEnvInit" (function int (* t) int int (* t))) - env +oci-default+ 0 nil))) - (format t ";; OEI: reutrned ~d~%" x) - (setq *oci-env* env)))))) - -(defun oci-check-return (value) - (if (= value +oci-invalid-handle+) - (error "Invalid Handle"))) - -(defun oci-get-handle (&key type) - (if (null *oci-initialized*) - (oci-init)) - (case type - (:error - (let ((ptr (make-alien (* t)))) - (let ((x (alien-funcall (extern-alien "OCIHandleAlloc" (function int unsigned-int (* t) int int (* t))) - (sap-ref-32 (alien-sap (deref *oci-env*)) 0) - ptr - +oci-default+ - 0 - nil))) - (oci-check-return x) - ptr))) - (:service-context - "OCISvcCtx") - (:statement - "OCIStmt") - (:describe - "OCIDescribe") - (:server - "OCIServer") - (:session - "OCISession") - (:transaction - "OCITrans") - (:complex-object - "OCIComplexObject") - (:security - "OCISecurity") - (t - (error "'~s' is not a valid OCI handle type" type)))) - -(defun oci-environment () - (let ((envhp (oci-handle-alloc :type :env))) - (oci-env-init envhp) - envhp)) - -;;; Check an OCI return code for erroricity and signal a reasonably -;;; informative condition if so. -;;; -;;; ERRHP provides an error handle which can be used to find -;;; subconditions; if it's not provided, subcodes won't be checked. -;;; -;;; NULLS-OK says that a NULL-VALUE-RETURNED subcondition condition is -;;; normal and needn't cause any signal. An error handle is required -;;; to detect this subcondition, so it doesn't make sense to set ERRHP -;;; unless NULLS-OK is set. - -(defmacro def-oci-routine ((c-oci-symbol lisp-oci-fn) c-return &rest c-parms) - (let ((ll (mapcar (lambda (x) (gensym)) c-parms))) - `(let ((%lisp-oci-fn (def-alien-routine (,c-oci-symbol ,(intern (concatenate 'string "%" (symbol-name lisp-oci-fn)))) - ,c-return ,@c-parms))) - (defun ,lisp-oci-fn (,@ll &key database nulls-ok) - (case (funcall %lisp-oci-fn ,@ll) - (#.+oci-success+ - +oci-success+) - (#.+oci-error+ - (handle-oci-error :database database :nulls-ok nulls-ok)) - (#.+oci-no-data+ - (error "OCI No Data Found")) - (#.+oci-success-with-info+ - (error "internal error: unexpected +oci-SUCCESS-WITH-INFO")) - (#.+oci-no-data+ - (error "OCI No Data")) - (#.+oci-invalid-handle+ - (error "OCI Invalid Handle")) - (#.+oci-need-data+ - (error "OCI Need Data")) - (#.+oci-still-executing+ - (error "OCI Still Executing")) - (#.+oci-continue+ - (error "OCI Continue")) - (t - (error "OCI unknown error, code=~A" (values)))))))) - - -(defmacro def-raw-oci-routine - ((c-oci-symbol lisp-oci-fn) c-return &rest c-parms) - (let ((ll (mapcar (lambda (x) (declare (ignore x)) (gensym)) c-parms))) - `(let ((%lisp-oci-fn (def-alien-routine (,c-oci-symbol ,(intern (concatenate 'string "%" (symbol-name lisp-oci-fn)))) - ,c-return ,@c-parms))) - (defun ,lisp-oci-fn (,@ll &key database nulls-ok) - (funcall %lisp-oci-fn ,@ll))))) - - -(def-oci-routine ("OCIInitialize" OCI-INITIALIZE) - int - (mode unsigned-long) ; ub4 - (ctxp (* t)) ; dvoid * - (malocfp (* t)) ; dvoid *(*) - (ralocfp (* t)) ; dvoid *(*) - (mfreefp (* t))) ; void *(*) - - -(def-oci-routine ("OCIEnvInit" OCI-ENV-INIT) - int - (envpp (* t)) ; OCIEnv ** - (mode unsigned-long) ; ub4 - (xtramem-sz unsigned-long) ; size_t - (usermempp (* t))) ; dvoid ** - -#+oci-8-1-5 -(def-oci-routine ("OCIEnvCreate" OCI-ENV-CREATE) - int - (p0 (* t)) - (p1 unsigned-int) - (p2 (* t)) - (p3 (* t)) - (p4 (* t)) - (p5 (* t)) - (p6 unsigned-long) - (p7 (* t))) - -(def-oci-routine ("OCIHandleAlloc" OCI-HANDLE-ALLOC) - int - (parenth (* t)) ; const dvoid * - (hndlpp (* t)) ; dvoid ** - (type unsigned-long) ; ub4 - (xtramem_sz unsigned-long) ; size_t - (usrmempp (* t))) ; dvoid ** - -(def-oci-routine ("OCIServerAttach" OCI-SERVER-ATTACH) - int - (srvhp (* t)) ; oci-server - (errhp (* t)) ; oci-error - (dblink c-string) ; :in - (dblink-len unsigned-long) ; int - (mode unsigned-long)) ; int - - -(def-oci-routine ("OCIHandleFree" OCI-HANDLE-FREE) - int - (p0 (* t)) ;; handle - (p1 unsigned-long)) ;;type - -(def-oci-routine ("OCILogon" OCI-LOGON) - int - (envhp (* t)) ; env - (errhp (* t)) ; err - (svchp (* t)) ; svc - (username c-string) ; username - (uname-len unsigned-long) ; - (passwd c-string) ; passwd - (password-len unsigned-long) ; - (dsn c-string) ; datasource - (dsn-len unsigned-long)) ; - -(def-oci-routine ("OCILogoff" OCI-LOGOFF) - int - (p0 (* t)) ; svc - (p1 (* t))) ; err - -(def-alien-routine ("OCIErrorGet" OCI-ERROR-GET) - void - (p0 (* t)) - (p1 unsigned-long) - (p2 c-string) - (p3 (* long)) - (p4 (* t)) - (p5 unsigned-long) - (p6 unsigned-long)) - -(def-oci-routine ("OCIStmtPrepare" OCI-STMT-PREPARE) - int - (p0 (* t)) - (p1 (* t)) - (p2 c-string) - (p3 unsigned-long) - (p4 unsigned-long) - (p5 unsigned-long)) - -(def-oci-routine ("OCIStmtExecute" OCI-STMT-EXECUTE) - int - (p0 (* t)) - (p1 (* t)) - (p2 (* t)) - (p3 unsigned-long) - (p4 unsigned-long) - (p5 (* t)) - (p6 (* t)) - (p7 unsigned-long)) - -(def-raw-oci-routine ("OCIParamGet" OCI-PARAM-GET) - int - (p0 (* t)) - (p1 unsigned-long) - (p2 (* t)) - (p3 (* t)) - (p4 unsigned-long)) - -(def-oci-routine ("OCIAttrGet" OCI-ATTR-GET) - int - (p0 (* t)) - (p1 unsigned-long) - (p2 (* t)) - (p3 (* unsigned-long)) - (p4 unsigned-long) - (p5 (* t))) - -#+nil -(def-oci-routine ("OCIAttrSet" OCI-ATTR-SET) - int - (trgthndlp (* t)) - (trgthndltyp int :in) - (attributep (* t)) - (size int) - (attrtype int) - (errhp oci-error)) - -(def-oci-routine ("OCIDefineByPos" OCI-DEFINE-BY-POS) - int - (p0 (* t)) - (p1 (* t)) - (p2 (* t)) - (p3 unsigned-long) - (p4 (* t)) - (p5 unsigned-long) - (p6 unsigned-short) - (p7 (* t)) - (p8 (* t)) - (p9 (* t)) - (p10 unsigned-long)) - -(def-oci-routine ("OCIStmtFetch" OCI-STMT-FETCH) - int - (stmthp (* t)) - (errhp (* t)) - (p2 unsigned-long) - (p3 unsigned-short) - (p4 unsigned-long)) - - -(def-oci-routine ("OCITransStart" OCI-TRANS-START) - int - (svchp (* t)) - (errhp (* t)) - (p2 unsigned-short) - (p3 unsigned-short)) - -(def-oci-routine ("OCITransCommit" OCI-TRANS-COMMIT) - int - (svchp (* t)) - (errhp (* t)) - (p2 unsigned-short)) - -(def-oci-routine ("OCITransRollback" OCI-TRANS-ROLLBACK) - int - (svchp (* t)) - (errhp (* t)) - (p2 unsigned-short)) - - diff --git a/db-oracle/oracle.lisp b/db-oracle/oracle.lisp new file mode 100644 index 0000000..1e0ed79 --- /dev/null +++ b/db-oracle/oracle.lisp @@ -0,0 +1,318 @@ +;;; -*- Mode: Lisp -*- +;;; $Id: oracle.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $ + +;;; MaiSQL --- Common Lisp Interface Layer to SQL Databases +;;; This is copyrighted software. See documentation for terms. +;;; +;;; oracle.lisp --- FFI interface to Oracle on Unix +;;; +;;; The present content of this file is orented specifically towards +;;; Oracle 8.0.5.1 under Linux, linking against libclntsh.so + +(in-package :clsql-oracle) + +;; + +(defvar *oci-initialized* nil) + +(defvar *oci-env* nil) + + +;; +;; Opaque pointer types +;; + +(def-alien-type oci-env (* t)) + +(def-alien-type oci-server (* t)) + +(def-alien-type oci-error (* t)) + +(def-alien-type oci-svc-ctx (* t)) + +(def-alien-type oci-stmt (* t)) + + +(defvar *oci-handle-types* + '(:error ; error report handle (OCIError) + :service-context ; service context handle (OCISvcCtx) + :statement ; statement (application request) handle (OCIStmt) + :describe ; select list description handle (OCIDescribe) + :server ; server context handle (OCIServer) + :session ; user session handle (OCISession) + :transaction ; transaction context handle (OCITrans) + :complex-object ; complex object retrieval handle (OCIComplexObject) + :security)) ; security handle (OCISecurity) + +(defstruct oci-handle + (type :unknown) + (pointer (make-alien (* t)))) + +(defun oci-init (&key (mode +oci-default+)) + (let ((x (alien-funcall (extern-alien "OCIInitialize" (function int int (* t) (* t) (* t) (* t))) + mode nil nil nil nil))) + (if (= x 0) + (let ((env (make-alien oci-env))) + (setq *oci-initialized* mode) + (let ((x (alien-funcall (extern-alien "OCIEnvInit" (function int (* t) int int (* t))) + env +oci-default+ 0 nil))) + (format t ";; OEI: reutrned ~d~%" x) + (setq *oci-env* env)))))) + +(defun oci-check-return (value) + (if (= value +oci-invalid-handle+) + (error "Invalid Handle"))) + +(defun oci-get-handle (&key type) + (if (null *oci-initialized*) + (oci-init)) + (case type + (:error + (let ((ptr (make-alien (* t)))) + (let ((x (alien-funcall (extern-alien "OCIHandleAlloc" (function int unsigned-int (* t) int int (* t))) + (sap-ref-32 (alien-sap (deref *oci-env*)) 0) + ptr + +oci-default+ + 0 + nil))) + (oci-check-return x) + ptr))) + (:service-context + "OCISvcCtx") + (:statement + "OCIStmt") + (:describe + "OCIDescribe") + (:server + "OCIServer") + (:session + "OCISession") + (:transaction + "OCITrans") + (:complex-object + "OCIComplexObject") + (:security + "OCISecurity") + (t + (error "'~s' is not a valid OCI handle type" type)))) + +(defun oci-environment () + (let ((envhp (oci-handle-alloc :type :env))) + (oci-env-init envhp) + envhp)) + +;;; Check an OCI return code for erroricity and signal a reasonably +;;; informative condition if so. +;;; +;;; ERRHP provides an error handle which can be used to find +;;; subconditions; if it's not provided, subcodes won't be checked. +;;; +;;; NULLS-OK says that a NULL-VALUE-RETURNED subcondition condition is +;;; normal and needn't cause any signal. An error handle is required +;;; to detect this subcondition, so it doesn't make sense to set ERRHP +;;; unless NULLS-OK is set. + +(defmacro def-oci-routine ((c-oci-symbol lisp-oci-fn) c-return &rest c-parms) + (let ((ll (mapcar (lambda (x) (gensym)) c-parms))) + `(let ((%lisp-oci-fn (def-alien-routine (,c-oci-symbol ,(intern (concatenate 'string "%" (symbol-name lisp-oci-fn)))) + ,c-return ,@c-parms))) + (defun ,lisp-oci-fn (,@ll &key database nulls-ok) + (case (funcall %lisp-oci-fn ,@ll) + (#.+oci-success+ + +oci-success+) + (#.+oci-error+ + (handle-oci-error :database database :nulls-ok nulls-ok)) + (#.+oci-no-data+ + (error "OCI No Data Found")) + (#.+oci-success-with-info+ + (error "internal error: unexpected +oci-SUCCESS-WITH-INFO")) + (#.+oci-no-data+ + (error "OCI No Data")) + (#.+oci-invalid-handle+ + (error "OCI Invalid Handle")) + (#.+oci-need-data+ + (error "OCI Need Data")) + (#.+oci-still-executing+ + (error "OCI Still Executing")) + (#.+oci-continue+ + (error "OCI Continue")) + (t + (error "OCI unknown error, code=~A" (values)))))))) + + +(defmacro def-raw-oci-routine + ((c-oci-symbol lisp-oci-fn) c-return &rest c-parms) + (let ((ll (mapcar (lambda (x) (declare (ignore x)) (gensym)) c-parms))) + `(let ((%lisp-oci-fn (def-alien-routine (,c-oci-symbol ,(intern (concatenate 'string "%" (symbol-name lisp-oci-fn)))) + ,c-return ,@c-parms))) + (defun ,lisp-oci-fn (,@ll &key database nulls-ok) + (funcall %lisp-oci-fn ,@ll))))) + + +(def-oci-routine ("OCIInitialize" OCI-INITIALIZE) + int + (mode unsigned-long) ; ub4 + (ctxp (* t)) ; dvoid * + (malocfp (* t)) ; dvoid *(*) + (ralocfp (* t)) ; dvoid *(*) + (mfreefp (* t))) ; void *(*) + + +(def-oci-routine ("OCIEnvInit" OCI-ENV-INIT) + int + (envpp (* t)) ; OCIEnv ** + (mode unsigned-long) ; ub4 + (xtramem-sz unsigned-long) ; size_t + (usermempp (* t))) ; dvoid ** + +#+oci-8-1-5 +(def-oci-routine ("OCIEnvCreate" OCI-ENV-CREATE) + int + (p0 (* t)) + (p1 unsigned-int) + (p2 (* t)) + (p3 (* t)) + (p4 (* t)) + (p5 (* t)) + (p6 unsigned-long) + (p7 (* t))) + +(def-oci-routine ("OCIHandleAlloc" OCI-HANDLE-ALLOC) + int + (parenth (* t)) ; const dvoid * + (hndlpp (* t)) ; dvoid ** + (type unsigned-long) ; ub4 + (xtramem_sz unsigned-long) ; size_t + (usrmempp (* t))) ; dvoid ** + +(def-oci-routine ("OCIServerAttach" OCI-SERVER-ATTACH) + int + (srvhp (* t)) ; oci-server + (errhp (* t)) ; oci-error + (dblink c-string) ; :in + (dblink-len unsigned-long) ; int + (mode unsigned-long)) ; int + + +(def-oci-routine ("OCIHandleFree" OCI-HANDLE-FREE) + int + (p0 (* t)) ;; handle + (p1 unsigned-long)) ;;type + +(def-oci-routine ("OCILogon" OCI-LOGON) + int + (envhp (* t)) ; env + (errhp (* t)) ; err + (svchp (* t)) ; svc + (username c-string) ; username + (uname-len unsigned-long) ; + (passwd c-string) ; passwd + (password-len unsigned-long) ; + (dsn c-string) ; datasource + (dsn-len unsigned-long)) ; + +(def-oci-routine ("OCILogoff" OCI-LOGOFF) + int + (p0 (* t)) ; svc + (p1 (* t))) ; err + +(def-alien-routine ("OCIErrorGet" OCI-ERROR-GET) + void + (p0 (* t)) + (p1 unsigned-long) + (p2 c-string) + (p3 (* long)) + (p4 (* t)) + (p5 unsigned-long) + (p6 unsigned-long)) + +(def-oci-routine ("OCIStmtPrepare" OCI-STMT-PREPARE) + int + (p0 (* t)) + (p1 (* t)) + (p2 c-string) + (p3 unsigned-long) + (p4 unsigned-long) + (p5 unsigned-long)) + +(def-oci-routine ("OCIStmtExecute" OCI-STMT-EXECUTE) + int + (p0 (* t)) + (p1 (* t)) + (p2 (* t)) + (p3 unsigned-long) + (p4 unsigned-long) + (p5 (* t)) + (p6 (* t)) + (p7 unsigned-long)) + +(def-raw-oci-routine ("OCIParamGet" OCI-PARAM-GET) + int + (p0 (* t)) + (p1 unsigned-long) + (p2 (* t)) + (p3 (* t)) + (p4 unsigned-long)) + +(def-oci-routine ("OCIAttrGet" OCI-ATTR-GET) + int + (p0 (* t)) + (p1 unsigned-long) + (p2 (* t)) + (p3 (* unsigned-long)) + (p4 unsigned-long) + (p5 (* t))) + +#+nil +(def-oci-routine ("OCIAttrSet" OCI-ATTR-SET) + int + (trgthndlp (* t)) + (trgthndltyp int :in) + (attributep (* t)) + (size int) + (attrtype int) + (errhp oci-error)) + +(def-oci-routine ("OCIDefineByPos" OCI-DEFINE-BY-POS) + int + (p0 (* t)) + (p1 (* t)) + (p2 (* t)) + (p3 unsigned-long) + (p4 (* t)) + (p5 unsigned-long) + (p6 unsigned-short) + (p7 (* t)) + (p8 (* t)) + (p9 (* t)) + (p10 unsigned-long)) + +(def-oci-routine ("OCIStmtFetch" OCI-STMT-FETCH) + int + (stmthp (* t)) + (errhp (* t)) + (p2 unsigned-long) + (p3 unsigned-short) + (p4 unsigned-long)) + + +(def-oci-routine ("OCITransStart" OCI-TRANS-START) + int + (svchp (* t)) + (errhp (* t)) + (p2 unsigned-short) + (p3 unsigned-short)) + +(def-oci-routine ("OCITransCommit" OCI-TRANS-COMMIT) + int + (svchp (* t)) + (errhp (* t)) + (p2 unsigned-short)) + +(def-oci-routine ("OCITransRollback" OCI-TRANS-ROLLBACK) + int + (svchp (* t)) + (errhp (* t)) + (p2 unsigned-short)) + + diff --git a/db-postgresql-socket/postgresql-socket-api.cl b/db-postgresql-socket/postgresql-socket-api.cl deleted file mode 100644 index 8a580b7..0000000 --- a/db-postgresql-socket/postgresql-socket-api.cl +++ /dev/null @@ -1,832 +0,0 @@ -;;;; -*- 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-api.cl,v 1.2 2002/09/29 18:54:17 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 -;;;; - Added initialization variable -;;;; - Added field type processing - - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :postgresql-socket) - -(uffi:def-enum pgsql-ftype - ((:bytea 17) - (:int2 21) - (:int4 23) - (:int8 20) - (:float4 700) - (:float8 701))) - -(defmethod database-type-library-loaded ((database-type - (eql :postgresql-socket))) - "T if foreign library was able to be loaded successfully. Always true for -socket interface" - t) - - -;;; 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)) - - -(defun read-socket-sequence (string stream) -"KMR -- Added to support reading from binary stream into a string" - (declare (optimize (speed 3) (safety 0)) - (string string)) - (dotimes (i (length string)) - (declare (fixnum i)) - (setf (char string i) (code-char (read-byte stream)))) - string) - - -;;; Support for encrypted password transmission - -(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 - (uffi:find-foreign-library "libcrypt" - '("/usr/lib/" "/usr/local/lib/" "/lib/")) - :supporting-libraries '("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 - (funcall (fdefinition '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-socket-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-field (socket type) - (let ((length (- (read-socket-value 'int32 socket) 4))) - (case type - ((:int32 :int64) - (read-integer-from-socket socket length)) - (:double - (read-double-from-socket socket length)) - (t - (let ((result (make-string length))) - (read-socket-sequence result socket) - result))))) - -(uffi:def-constant +char-code-zero+ (char-code #\0)) -(uffi:def-constant +char-code-minus+ (char-code #\-)) -(uffi:def-constant +char-code-plus+ (char-code #\+)) -(uffi:def-constant +char-code-period+ (char-code #\.)) -(uffi:def-constant +char-code-lower-e+ (char-code #\e)) -(uffi:def-constant +char-code-upper-e+ (char-code #\E)) - -(defun read-integer-from-socket (socket length) - (declare (fixnum length)) - (if (zerop length) - nil - (let ((val 0) - (first-char (read-byte socket)) - (minusp nil)) - (declare (fixnum first-char)) - (decf length) ;; read first char - (cond - ((= first-char +char-code-minus+) - (setq minusp t)) - ((= first-char +char-code-plus+) - ) ;; nothing to do - (t - (setq val (- first-char +char-code-zero+)))) - - (dotimes (i length) - (declare (fixnum i)) - (setq val (+ - (* 10 val) - (- (read-byte socket) +char-code-zero+)))) - (if minusp - (- val) - val)))) - -(defmacro ascii-digit (int) - (let ((offset (gensym))) - `(let ((,offset (- ,int +char-code-zero+))) - (declare (fixnum ,int ,offset)) - (if (and (>= ,offset 0) - (< ,offset 10)) - ,offset - nil)))) - -(defun read-double-from-socket (socket length) - (declare (fixnum length)) - (let ((before-decimal 0) - (after-decimal 0) - (decimal-count 0) - (exponent 0) - (decimalp nil) - (minusp nil) - (result nil) - (char (read-byte socket))) - (declare (fixnum char exponent decimal-count)) - (decf length) ;; already read first character - (cond - ((= char +char-code-minus+) - (setq minusp t)) - ((= char +char-code-plus+) - ) - ((= char +char-code-period+) - (setq decimalp t)) - (t - (setq before-decimal (ascii-digit char)) - (unless before-decimal - (error "Unexpected value")))) - - (block loop - (dotimes (i length) - (setq char (read-byte socket)) - ;; (format t "~&len:~D, i:~D, char:~D, minusp:~A, decimalp:~A" length i char minusp decimalp) - (let ((weight (ascii-digit char))) - (cond - ((and weight (not decimalp)) ;; before decimal point - (setq before-decimal (+ weight (* 10 before-decimal)))) - ((and weight decimalp) ;; after decimal point - (setq after-decimal (+ weight (* 10 after-decimal))) - (incf decimal-count)) - ((and (= char +char-code-period+)) - (setq decimalp t)) - ((or (= char +char-code-lower-e+) ;; E is for exponent - (= char +char-code-upper-e+)) - (setq exponent (read-integer-from-socket socket (- length i 1))) - (setq exponent (or exponent 0)) - (return-from loop)) - (t - (break "Unexpected value")) - ) - ))) - (setq result (* (+ (coerce before-decimal 'double-float) - (* after-decimal - (expt 10 (- decimal-count)))) - (expt 10 exponent))) - (if minusp - (- result) - result))) - - -#+ignore -(defun read-double-from-socket (socket length) - (let ((result (make-string length))) - (read-socket-sequence result socket) - (let ((*read-default-float-format* 'double-float)) - (read-from-string result)))) - -(defun read-cursor-row (cursor types) - (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 i from 0 - for null-p = (zerop null-bit) - if null-p - collect nil - else - collect - (read-field socket (nth i types))))) - (#.+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 map-into-indexed (result-seq func seq) - (dotimes (i (length seq)) - (declare (fixnum i)) - (setf (elt result-seq i) - (funcall func (elt seq i) i))) - result-seq) - -(defun copy-cursor-row (cursor sequence types) - (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 - #+ignore - (let* ((count (length sequence)) - (null-vector (read-null-bit-vector socket count))) - (dotimes (i count) - (declare (fixnum i)) - (if (zerop (elt null-vector i)) - (setf (elt sequence i) nil) - (let ((value (read-field socket (nth i types)))) - (setf (elt sequence i) value))))) - (map-into-indexed - sequence - #'(lambda (null-bit i) - (if (zerop null-bit) - nil - (read-field socket (nth i types)))) - (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 &optional (types nil)) - (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 types) - while row - collect row - finally - (wait-for-query-results connection)))) diff --git a/db-postgresql-socket/postgresql-socket-api.lisp b/db-postgresql-socket/postgresql-socket-api.lisp new file mode 100644 index 0000000..afd0014 --- /dev/null +++ b/db-postgresql-socket/postgresql-socket-api.lisp @@ -0,0 +1,832 @@ +;;;; -*- 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-api.lisp,v 1.1 2002/09/30 10:19:23 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 +;;;; - Added initialization variable +;;;; - Added field type processing + + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :postgresql-socket) + +(uffi:def-enum pgsql-ftype + ((:bytea 17) + (:int2 21) + (:int4 23) + (:int8 20) + (:float4 700) + (:float8 701))) + +(defmethod database-type-library-loaded ((database-type + (eql :postgresql-socket))) + "T if foreign library was able to be loaded successfully. Always true for +socket interface" + t) + + +;;; 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)) + + +(defun read-socket-sequence (string stream) +"KMR -- Added to support reading from binary stream into a string" + (declare (optimize (speed 3) (safety 0)) + (string string)) + (dotimes (i (length string)) + (declare (fixnum i)) + (setf (char string i) (code-char (read-byte stream)))) + string) + + +;;; Support for encrypted password transmission + +(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 + (uffi:find-foreign-library "libcrypt" + '("/usr/lib/" "/usr/local/lib/" "/lib/")) + :supporting-libraries '("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 + (funcall (fdefinition '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-socket-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-field (socket type) + (let ((length (- (read-socket-value 'int32 socket) 4))) + (case type + ((:int32 :int64) + (read-integer-from-socket socket length)) + (:double + (read-double-from-socket socket length)) + (t + (let ((result (make-string length))) + (read-socket-sequence result socket) + result))))) + +(uffi:def-constant +char-code-zero+ (char-code #\0)) +(uffi:def-constant +char-code-minus+ (char-code #\-)) +(uffi:def-constant +char-code-plus+ (char-code #\+)) +(uffi:def-constant +char-code-period+ (char-code #\.)) +(uffi:def-constant +char-code-lower-e+ (char-code #\e)) +(uffi:def-constant +char-code-upper-e+ (char-code #\E)) + +(defun read-integer-from-socket (socket length) + (declare (fixnum length)) + (if (zerop length) + nil + (let ((val 0) + (first-char (read-byte socket)) + (minusp nil)) + (declare (fixnum first-char)) + (decf length) ;; read first char + (cond + ((= first-char +char-code-minus+) + (setq minusp t)) + ((= first-char +char-code-plus+) + ) ;; nothing to do + (t + (setq val (- first-char +char-code-zero+)))) + + (dotimes (i length) + (declare (fixnum i)) + (setq val (+ + (* 10 val) + (- (read-byte socket) +char-code-zero+)))) + (if minusp + (- val) + val)))) + +(defmacro ascii-digit (int) + (let ((offset (gensym))) + `(let ((,offset (- ,int +char-code-zero+))) + (declare (fixnum ,int ,offset)) + (if (and (>= ,offset 0) + (< ,offset 10)) + ,offset + nil)))) + +(defun read-double-from-socket (socket length) + (declare (fixnum length)) + (let ((before-decimal 0) + (after-decimal 0) + (decimal-count 0) + (exponent 0) + (decimalp nil) + (minusp nil) + (result nil) + (char (read-byte socket))) + (declare (fixnum char exponent decimal-count)) + (decf length) ;; already read first character + (cond + ((= char +char-code-minus+) + (setq minusp t)) + ((= char +char-code-plus+) + ) + ((= char +char-code-period+) + (setq decimalp t)) + (t + (setq before-decimal (ascii-digit char)) + (unless before-decimal + (error "Unexpected value")))) + + (block loop + (dotimes (i length) + (setq char (read-byte socket)) + ;; (format t "~&len:~D, i:~D, char:~D, minusp:~A, decimalp:~A" length i char minusp decimalp) + (let ((weight (ascii-digit char))) + (cond + ((and weight (not decimalp)) ;; before decimal point + (setq before-decimal (+ weight (* 10 before-decimal)))) + ((and weight decimalp) ;; after decimal point + (setq after-decimal (+ weight (* 10 after-decimal))) + (incf decimal-count)) + ((and (= char +char-code-period+)) + (setq decimalp t)) + ((or (= char +char-code-lower-e+) ;; E is for exponent + (= char +char-code-upper-e+)) + (setq exponent (read-integer-from-socket socket (- length i 1))) + (setq exponent (or exponent 0)) + (return-from loop)) + (t + (break "Unexpected value")) + ) + ))) + (setq result (* (+ (coerce before-decimal 'double-float) + (* after-decimal + (expt 10 (- decimal-count)))) + (expt 10 exponent))) + (if minusp + (- result) + result))) + + +#+ignore +(defun read-double-from-socket (socket length) + (let ((result (make-string length))) + (read-socket-sequence result socket) + (let ((*read-default-float-format* 'double-float)) + (read-from-string result)))) + +(defun read-cursor-row (cursor types) + (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 i from 0 + for null-p = (zerop null-bit) + if null-p + collect nil + else + collect + (read-field socket (nth i types))))) + (#.+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 map-into-indexed (result-seq func seq) + (dotimes (i (length seq)) + (declare (fixnum i)) + (setf (elt result-seq i) + (funcall func (elt seq i) i))) + result-seq) + +(defun copy-cursor-row (cursor sequence types) + (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 + #+ignore + (let* ((count (length sequence)) + (null-vector (read-null-bit-vector socket count))) + (dotimes (i count) + (declare (fixnum i)) + (if (zerop (elt null-vector i)) + (setf (elt sequence i) nil) + (let ((value (read-field socket (nth i types)))) + (setf (elt sequence i) value))))) + (map-into-indexed + sequence + #'(lambda (null-bit i) + (if (zerop null-bit) + nil + (read-field socket (nth i types)))) + (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 &optional (types nil)) + (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 types) + while row + collect row + finally + (wait-for-query-results connection)))) diff --git a/db-postgresql-socket/postgresql-socket-package.cl b/db-postgresql-socket/postgresql-socket-package.cl deleted file mode 100644 index 9b46110..0000000 --- a/db-postgresql-socket/postgresql-socket-package.cl +++ /dev/null @@ -1,62 +0,0 @@ -;;;; -*- 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/09/18 07:43:41 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) - -#+lispworks (require "comm") - -(defpackage :postgresql-socket - (:use :common-lisp) - (:export #:pgsql-ftype - #:pgsql-ftype#bytea - #:pgsql-ftype#int2 - #:pgsql-ftype#int4 - #:pgsql-ftype#int8 - #:pgsql-ftype#float4 - #:pgsql-ftype#float8 - - #:+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/db-postgresql-socket/postgresql-socket-package.lisp b/db-postgresql-socket/postgresql-socket-package.lisp new file mode 100644 index 0000000..04b08a9 --- /dev/null +++ b/db-postgresql-socket/postgresql-socket-package.lisp @@ -0,0 +1,62 @@ +;;;; -*- 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.lisp,v 1.1 2002/09/30 10:19:23 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) + +#+lispworks (require "comm") + +(defpackage :postgresql-socket + (:use :common-lisp) + (:export #:pgsql-ftype + #:pgsql-ftype#bytea + #:pgsql-ftype#int2 + #:pgsql-ftype#int4 + #:pgsql-ftype#int8 + #:pgsql-ftype#float4 + #:pgsql-ftype#float8 + + #:+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/db-postgresql-socket/postgresql-socket-sql.cl b/db-postgresql-socket/postgresql-socket-sql.cl deleted file mode 100644 index 9ca2af3..0000000 --- a/db-postgresql-socket/postgresql-socket-sql.cl +++ /dev/null @@ -1,309 +0,0 @@ -;;;; -*- 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.2 2002/09/29 18:54:17 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-base-sys :postgresql-socket) - (:export #:postgresql-socket-database) - (:documentation "This is the CLSQL socket interface to PostgreSQL.")) - -(in-package :clsql-postgresql-socket) - -;; interface foreign library loading routines - -(defmethod database-type-library-loaded ((database-type (eql :postgresql-socket))) - t) - -(defmethod clsql-base-sys:database-type-load-foreign ((database-type (eql :postgresql-socket))) - t) - -(clsql-base-sys:database-type-load-foreign :postgresql-socket) - - -;; Field type conversion - -(defun make-type-list-for-auto (cursor) - (let* ((fields (postgresql-cursor-fields cursor)) - (num-fields (length fields)) - (new-types '())) - (dotimes (i num-fields) - (declare (fixnum i)) - (push (canonical-field-type fields i) new-types)) - (nreverse new-types))) - -(defun canonical-field-type (fields index) - "Extracts canonical field type from fields list" - (let ((oid (cadr (nth index fields)))) - (case oid - ((#.pgsql-ftype#bytea - #.pgsql-ftype#int2 - #.pgsql-ftype#int4) - :int32) - (#.pgsql-ftype#int8 - :int64) - ((#.pgsql-ftype#float4 - #.pgsql-ftype#float8) - :double) - (otherwise - t)))) - -(defun canonicalize-types (types cursor) - (if (null types) - nil - (let ((auto-list (make-type-list-for-auto cursor))) - (cond - ((listp types) - (canonicalize-type-list types auto-list)) - ((eq types :auto) - auto-list) - (t - nil))))) - -(defun canonicalize-type-list (types auto-list) - "Ensure a field type list meets expectations. -Duplicated from clsql-uffi package so that this interface -doesn't depend on UFFI." - (let ((length-types (length types)) - (new-types '())) - (loop for i from 0 below (length auto-list) - do - (if (>= i length-types) - (push t new-types) ;; types is shorted than num-fields - (push - (case (nth i types) - (:int - (case (nth i auto-list) - (:int32 - :int32) - (:int64 - :int64) - (t - t))) - (:double - (case (nth i auto-list) - (:double - :double) - (t - t))) - (t - t)) - new-types))) - (nreverse new-types))) - - -(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-type ((database postgresql-socket-database)) - :postgresql-socket) - -(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)) - (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))) - (:no-error (connection) - ;; Success, make instance - (make-instance 'postgresql-socket-database - :name (database-name-from-spec connection-spec - database-type) - :connection-spec connection-spec - :connection connection))))) - -(defmethod database-disconnect ((database postgresql-socket-database)) - (close-postgresql-connection (database-connection database)) - t) - -(defmethod database-query (expression (database postgresql-socket-database) types) - (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.")) - (setq types (canonicalize-types types cursor)) - (loop for row = (read-cursor-row cursor types) - 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."))))))) - -(defstruct postgresql-socket-result-set - (done nil) - (cursor nil) - (types nil)) - -(defmethod database-query-result-set (expression (database postgresql-socket-database) - &key full-set types - ) - (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 (make-postgresql-socket-result-set - :done nil - :cursor cursor - :types (canonicalize-types types cursor)) - (length (postgresql-cursor-fields cursor))))))) - -(defmethod database-dump-result-set (result-set - (database postgresql-socket-database)) - (if (postgresql-socket-result-set-done result-set) - t - (with-postgresql-handlers (database) - (loop while (skip-cursor-row - (postgresql-socket-result-set-cursor result-set)) - finally (setf (postgresql-socket-result-set-done result-set) t))))) - -(defmethod database-store-next-row (result-set - (database postgresql-socket-database) - list) - (let ((cursor (postgresql-socket-result-set-cursor result-set))) - (with-postgresql-handlers (database) - (if (copy-cursor-row cursor - list - (postgresql-socket-result-set-types - result-set)) - t - (prog1 nil - (setf (postgresql-socket-result-set-done result-set) t) - (wait-for-query-results (database-connection database))))))) - -(when (clsql-base-sys:database-type-library-loaded :postgresql-socket) - (clsql-base-sys:initialize-database-type :database-type :postgresql-socket)) diff --git a/db-postgresql-socket/postgresql-socket-sql.lisp b/db-postgresql-socket/postgresql-socket-sql.lisp new file mode 100644 index 0000000..acd93c3 --- /dev/null +++ b/db-postgresql-socket/postgresql-socket-sql.lisp @@ -0,0 +1,309 @@ +;;;; -*- 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.lisp,v 1.1 2002/09/30 10:19:23 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-base-sys :postgresql-socket) + (:export #:postgresql-socket-database) + (:documentation "This is the CLSQL socket interface to PostgreSQL.")) + +(in-package :clsql-postgresql-socket) + +;; interface foreign library loading routines + +(defmethod database-type-library-loaded ((database-type (eql :postgresql-socket))) + t) + +(defmethod clsql-base-sys:database-type-load-foreign ((database-type (eql :postgresql-socket))) + t) + +(clsql-base-sys:database-type-load-foreign :postgresql-socket) + + +;; Field type conversion + +(defun make-type-list-for-auto (cursor) + (let* ((fields (postgresql-cursor-fields cursor)) + (num-fields (length fields)) + (new-types '())) + (dotimes (i num-fields) + (declare (fixnum i)) + (push (canonical-field-type fields i) new-types)) + (nreverse new-types))) + +(defun canonical-field-type (fields index) + "Extracts canonical field type from fields list" + (let ((oid (cadr (nth index fields)))) + (case oid + ((#.pgsql-ftype#bytea + #.pgsql-ftype#int2 + #.pgsql-ftype#int4) + :int32) + (#.pgsql-ftype#int8 + :int64) + ((#.pgsql-ftype#float4 + #.pgsql-ftype#float8) + :double) + (otherwise + t)))) + +(defun canonicalize-types (types cursor) + (if (null types) + nil + (let ((auto-list (make-type-list-for-auto cursor))) + (cond + ((listp types) + (canonicalize-type-list types auto-list)) + ((eq types :auto) + auto-list) + (t + nil))))) + +(defun canonicalize-type-list (types auto-list) + "Ensure a field type list meets expectations. +Duplicated from clsql-uffi package so that this interface +doesn't depend on UFFI." + (let ((length-types (length types)) + (new-types '())) + (loop for i from 0 below (length auto-list) + do + (if (>= i length-types) + (push t new-types) ;; types is shorted than num-fields + (push + (case (nth i types) + (:int + (case (nth i auto-list) + (:int32 + :int32) + (:int64 + :int64) + (t + t))) + (:double + (case (nth i auto-list) + (:double + :double) + (t + t))) + (t + t)) + new-types))) + (nreverse new-types))) + + +(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-type ((database postgresql-socket-database)) + :postgresql-socket) + +(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)) + (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))) + (:no-error (connection) + ;; Success, make instance + (make-instance 'postgresql-socket-database + :name (database-name-from-spec connection-spec + database-type) + :connection-spec connection-spec + :connection connection))))) + +(defmethod database-disconnect ((database postgresql-socket-database)) + (close-postgresql-connection (database-connection database)) + t) + +(defmethod database-query (expression (database postgresql-socket-database) types) + (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.")) + (setq types (canonicalize-types types cursor)) + (loop for row = (read-cursor-row cursor types) + 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."))))))) + +(defstruct postgresql-socket-result-set + (done nil) + (cursor nil) + (types nil)) + +(defmethod database-query-result-set (expression (database postgresql-socket-database) + &key full-set types + ) + (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 (make-postgresql-socket-result-set + :done nil + :cursor cursor + :types (canonicalize-types types cursor)) + (length (postgresql-cursor-fields cursor))))))) + +(defmethod database-dump-result-set (result-set + (database postgresql-socket-database)) + (if (postgresql-socket-result-set-done result-set) + t + (with-postgresql-handlers (database) + (loop while (skip-cursor-row + (postgresql-socket-result-set-cursor result-set)) + finally (setf (postgresql-socket-result-set-done result-set) t))))) + +(defmethod database-store-next-row (result-set + (database postgresql-socket-database) + list) + (let ((cursor (postgresql-socket-result-set-cursor result-set))) + (with-postgresql-handlers (database) + (if (copy-cursor-row cursor + list + (postgresql-socket-result-set-types + result-set)) + t + (prog1 nil + (setf (postgresql-socket-result-set-done result-set) t) + (wait-for-query-results (database-connection database))))))) + +(when (clsql-base-sys:database-type-library-loaded :postgresql-socket) + (clsql-base-sys:initialize-database-type :database-type :postgresql-socket)) diff --git a/db-postgresql/postgresql-api.cl b/db-postgresql/postgresql-api.cl deleted file mode 100644 index 1e04187..0000000 --- a/db-postgresql/postgresql-api.cl +++ /dev/null @@ -1,267 +0,0 @@ -;;;; -*- 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-api.cl,v 1.1 2002/09/18 07:43:41 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) - -(uffi:def-enum pgsql-ftype - ((:bytea 17) - (:int2 21) - (:int4 23) - (:int8 20) - (:float4 700) - (:float8 701))) - -;;(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 (* :unsigned-char)) - -(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) - -(declaim (inline PQisBusy)) -(uffi:def-function ("PQisBusy" PQisBusy) - ((conn pgsql-conn)) - :module "postgresql" - :returning :int) - - -;;; Large objects support (MB) - -(defconstant +INV_ARCHIVE+ 65536) ; fe-lobj.c -(defconstant +INV_WRITE+ 131072) -(defconstant +INV_READ+ 262144) - -(declaim (inline lo-creat)) -(uffi:def-function ("lo_creat" lo-create) - ((conn pgsql-conn) - (mode :int)) - :module "postgresql" - :returning pgsql-oid) - -(declaim (inline lo-open)) -(uffi:def-function ("lo_open" lo-open) - ((conn pgsql-conn) - (oid pgsql-oid) - (mode :int)) - :module "postgresql" - :returning :int) - -(declaim (inline lo-write)) -(uffi:def-function ("lo_write" lo-write) - ((conn pgsql-conn) - (fd :int) - (data :cstring) - (size :int)) - :module "postgresql" - :returning :int) - -(declaim (inline lo-read)) -(uffi:def-function ("lo_read" lo-read) - ((conn pgsql-conn) - (fd :int) - (data (* :unsigned-char)) - (size :int)) - :module "postgresql" - :returning :int) - -(declaim (inline lo-lseek)) -(uffi:def-function ("lo_lseek" lo-lseek) - ((conn pgsql-conn) - (fd :int) - (offset :int) - (whence :int)) - :module "postgresql" - :returning :int) - -(declaim (inline lo-close)) -(uffi:def-function ("lo_close" lo-close) - ((conn pgsql-conn) - (fd :int)) - :module "postgresql" - :returning :int) - -(declaim (inline lo-unlink)) -(uffi:def-function ("lo_unlink" lo-unlink) - ((conn pgsql-conn) - (oid pgsql-oid)) - :module "postgresql" - :returning :int) diff --git a/db-postgresql/postgresql-api.lisp b/db-postgresql/postgresql-api.lisp new file mode 100644 index 0000000..f7ca361 --- /dev/null +++ b/db-postgresql/postgresql-api.lisp @@ -0,0 +1,267 @@ +;;;; -*- 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-api.lisp,v 1.1 2002/09/30 10:19:23 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) + +(uffi:def-enum pgsql-ftype + ((:bytea 17) + (:int2 21) + (:int4 23) + (:int8 20) + (:float4 700) + (:float8 701))) + +;;(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 (* :unsigned-char)) + +(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) + +(declaim (inline PQisBusy)) +(uffi:def-function ("PQisBusy" PQisBusy) + ((conn pgsql-conn)) + :module "postgresql" + :returning :int) + + +;;; Large objects support (MB) + +(defconstant +INV_ARCHIVE+ 65536) ; fe-lobj.c +(defconstant +INV_WRITE+ 131072) +(defconstant +INV_READ+ 262144) + +(declaim (inline lo-creat)) +(uffi:def-function ("lo_creat" lo-create) + ((conn pgsql-conn) + (mode :int)) + :module "postgresql" + :returning pgsql-oid) + +(declaim (inline lo-open)) +(uffi:def-function ("lo_open" lo-open) + ((conn pgsql-conn) + (oid pgsql-oid) + (mode :int)) + :module "postgresql" + :returning :int) + +(declaim (inline lo-write)) +(uffi:def-function ("lo_write" lo-write) + ((conn pgsql-conn) + (fd :int) + (data :cstring) + (size :int)) + :module "postgresql" + :returning :int) + +(declaim (inline lo-read)) +(uffi:def-function ("lo_read" lo-read) + ((conn pgsql-conn) + (fd :int) + (data (* :unsigned-char)) + (size :int)) + :module "postgresql" + :returning :int) + +(declaim (inline lo-lseek)) +(uffi:def-function ("lo_lseek" lo-lseek) + ((conn pgsql-conn) + (fd :int) + (offset :int) + (whence :int)) + :module "postgresql" + :returning :int) + +(declaim (inline lo-close)) +(uffi:def-function ("lo_close" lo-close) + ((conn pgsql-conn) + (fd :int)) + :module "postgresql" + :returning :int) + +(declaim (inline lo-unlink)) +(uffi:def-function ("lo_unlink" lo-unlink) + ((conn pgsql-conn) + (oid pgsql-oid)) + :module "postgresql" + :returning :int) diff --git a/db-postgresql/postgresql-loader.cl b/db-postgresql/postgresql-loader.cl deleted file mode 100644 index ac1729b..0000000 --- a/db-postgresql/postgresql-loader.cl +++ /dev/null @@ -1,52 +0,0 @@ -;;;; -*- 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/09/18 07:43:41 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-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.") - -(defvar *postgresql-library-loaded* nil - "T if foreign library was able to be loaded successfully") - -(defmethod clsql-base-sys:database-type-library-loaded ((database-type - (eql :postgresql))) - *postgresql-library-loaded*) - -(defmethod clsql-base-sys:database-type-load-foreign ((database-type - (eql :postgresql))) - (let ((libpath (uffi:find-foreign-library - "libpq" - '("/opt/postgresql/lib/" "/usr/local/lib/" - "/usr/lib/" "/postgresql/lib/" - "/usr/local/pgsql/lib/" "/usr/lib/pgsql/" - "/opt/pgsql/lib/pgsql") - :drive-letters '("C" "D" "E")))) - (if (uffi:load-foreign-library libpath - :module "postgresql" - :supporting-libraries - *postgresql-supporting-libraries*) - (setq *postgresql-library-loaded* t) - (warn "Can't load PostgreSQL client library ~A" libpath)))) - -(clsql-base-sys:database-type-load-foreign :postgresql) - diff --git a/db-postgresql/postgresql-loader.lisp b/db-postgresql/postgresql-loader.lisp new file mode 100644 index 0000000..5a0f039 --- /dev/null +++ b/db-postgresql/postgresql-loader.lisp @@ -0,0 +1,52 @@ +;;;; -*- 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.lisp,v 1.1 2002/09/30 10:19:23 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-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.") + +(defvar *postgresql-library-loaded* nil + "T if foreign library was able to be loaded successfully") + +(defmethod clsql-base-sys:database-type-library-loaded ((database-type + (eql :postgresql))) + *postgresql-library-loaded*) + +(defmethod clsql-base-sys:database-type-load-foreign ((database-type + (eql :postgresql))) + (let ((libpath (uffi:find-foreign-library + "libpq" + '("/opt/postgresql/lib/" "/usr/local/lib/" + "/usr/lib/" "/postgresql/lib/" + "/usr/local/pgsql/lib/" "/usr/lib/pgsql/" + "/opt/pgsql/lib/pgsql") + :drive-letters '("C" "D" "E")))) + (if (uffi:load-foreign-library libpath + :module "postgresql" + :supporting-libraries + *postgresql-supporting-libraries*) + (setq *postgresql-library-loaded* t) + (warn "Can't load PostgreSQL client library ~A" libpath)))) + +(clsql-base-sys:database-type-load-foreign :postgresql) + diff --git a/db-postgresql/postgresql-package.cl b/db-postgresql/postgresql-package.cl deleted file mode 100644 index ab6e5f2..0000000 --- a/db-postgresql/postgresql-package.cl +++ /dev/null @@ -1,84 +0,0 @@ -;;;; -*- 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/09/18 07:43:41 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 :clsql-uffi) - (: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 - - #:pgsql-ftype#bytea - #:pgsql-ftype#int2 - #:pgsql-ftype#int4 - #:pgsql-ftype#int8 - #:pgsql-ftype#float4 - #:pgsql-ftype#float8 - - ;; Functions - #:PQsetdbLogin - #:PQlogin - #:PQfinish - #:PQstatus - #:PQerrorMessage - #:PQexec - #:PQresultStatus - #:PQresultErrorMessage - #:PQntuples - #:PQnfields - #:PQfname - #:PQfnumber - #:PQftype - #:PQfsize - #:PQcmdStatus - #:PQoidStatus - #:PQcmdTuples - #:PQgetvalue - #:PQgetlength - #:PQgetisnull - #:PQclear - #:PQisBusy - - ;;Large Objects (Marc B) - #:lo-create - #:lo-open - #:lo-write - #:lo-read - #:lo-lseek - #:lo-close - #:lo-unlink - ) - (:documentation "This is the low-level interface to PostgreSQL.")) - - diff --git a/db-postgresql/postgresql-package.lisp b/db-postgresql/postgresql-package.lisp new file mode 100644 index 0000000..cd007c6 --- /dev/null +++ b/db-postgresql/postgresql-package.lisp @@ -0,0 +1,84 @@ +;;;; -*- 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.lisp,v 1.1 2002/09/30 10:19:23 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 :clsql-uffi) + (: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 + + #:pgsql-ftype#bytea + #:pgsql-ftype#int2 + #:pgsql-ftype#int4 + #:pgsql-ftype#int8 + #:pgsql-ftype#float4 + #:pgsql-ftype#float8 + + ;; Functions + #:PQsetdbLogin + #:PQlogin + #:PQfinish + #:PQstatus + #:PQerrorMessage + #:PQexec + #:PQresultStatus + #:PQresultErrorMessage + #:PQntuples + #:PQnfields + #:PQfname + #:PQfnumber + #:PQftype + #:PQfsize + #:PQcmdStatus + #:PQoidStatus + #:PQcmdTuples + #:PQgetvalue + #:PQgetlength + #:PQgetisnull + #:PQclear + #:PQisBusy + + ;;Large Objects (Marc B) + #:lo-create + #:lo-open + #:lo-write + #:lo-read + #:lo-lseek + #:lo-close + #:lo-unlink + ) + (:documentation "This is the low-level interface to PostgreSQL.")) + + diff --git a/db-postgresql/postgresql-sql.cl b/db-postgresql/postgresql-sql.cl deleted file mode 100644 index 54295d5..0000000 --- a/db-postgresql/postgresql-sql.cl +++ /dev/null @@ -1,358 +0,0 @@ -;;;; -*- 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/09/18 07:43:41 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-base-sys :postgresql :clsql-uffi) - (:export #:postgresql-database) - (:documentation "This is the CLSQL interface to PostgreSQL.")) - -(in-package :clsql-postgresql) - -;;; Field conversion functions - -(defun make-type-list-for-auto (num-fields res-ptr) - (let ((new-types '())) - (dotimes (i num-fields) - (declare (fixnum i)) - (let* ((type (PQftype res-ptr i))) - (push - (case type - ((#.pgsql-ftype#bytea - #.pgsql-ftype#int2 - #.pgsql-ftype#int4) - :int32) - (#.pgsql-ftype#int8 - :int64) - ((#.pgsql-ftype#float4 - #.pgsql-ftype#float8) - :double) - (otherwise - t)) - new-types))) - (nreverse new-types))) - -(defun canonicalize-types (types num-fields res-ptr) - (if (null types) - nil - (let ((auto-list (make-type-list-for-auto num-fields res-ptr))) - (cond - ((listp types) - (canonicalize-type-list types auto-list)) - ((eq types :auto) - auto-list) - (t - nil))))) - -(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-type ((database postgresql-database)) - :postgresql) - -(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-cstrings ((host-native host) - (user-native user) - (password-native password) - (db-native db) - (port-native port) - (options-native options) - (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) - :connection-spec connection-spec - :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) types) - (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 - (let ((num-fields (PQnfields result))) - (setq types - (canonicalize-types types num-fields - result)) - (loop for tuple-index from 0 below (PQntuples result) - collect - (loop for i from 0 below num-fields - collect - (if (zerop (PQgetisnull result tuple-index i)) - (convert-raw-field - (PQgetvalue result tuple-index i) - types 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) - (types nil) - (num-tuples 0 :type integer) - (num-fields 0 :type integer) - (tuple-index 0 :type integer)) - -(defmethod database-query-result-set (query-expression (database postgresql-database) - &key full-set types) - (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) - (let ((result-set (make-postgresql-result-set - :res-ptr result - :num-fields (PQnfields result) - :num-tuples (PQntuples result) - :types (canonicalize-types - types - (PQnfields result) - result)))) - (if full-set - (values result-set - (PQnfields result) - (PQntuples result)) - (values result-set - (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)) - (types (postgresql-result-set-types 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)) - (convert-raw-field - (PQgetvalue result tuple-index i) - types i) - nil)) - finally - (incf (postgresql-result-set-tuple-index result-set)) - (return list))))) - -;;; Large objects support (Marc B) - -(defmethod database-create-large-object ((database postgresql-database)) - (lo-create (database-conn-ptr database) - (logior postgresql::+INV_WRITE+ postgresql::+INV_READ+))) - - -#+mb-original -(defmethod database-write-large-object (object-id (data string) (database postgresql-database)) - (let ((ptr (database-conn-ptr database)) - (length (length data)) - (result nil) - (fd nil)) - (with-transaction (:database database) - (unwind-protect - (progn - (setf fd (lo-open ptr object-id postgresql::+INV_WRITE+)) - (when (>= fd 0) - (when (= (lo-write ptr fd data length) length) - (setf result t)))) - (progn - (when (and fd (>= fd 0)) - (lo-close ptr fd)) - ))) - result)) - -(defmethod database-write-large-object (object-id (data string) (database postgresql-database)) - (let ((ptr (database-conn-ptr database)) - (length (length data)) - (result nil) - (fd nil)) - (database-execute-command "begin" database) - (unwind-protect - (progn - (setf fd (lo-open ptr object-id postgresql::+INV_WRITE+)) - (when (>= fd 0) - (when (= (lo-write ptr fd data length) length) - (setf result t)))) - (progn - (when (and fd (>= fd 0)) - (lo-close ptr fd)) - (database-execute-command (if result "commit" "rollback") database))) - result)) - -;; (MB) the begin/commit/rollback stuff will be removed when with-transaction wil be implemented -;; (KMR) Can't use with-transaction since that function is in high-level code -(defmethod database-read-large-object (object-id (database postgresql-database)) - (let ((ptr (database-conn-ptr database)) - (buffer nil) - (result nil) - (length 0) - (fd nil)) - (unwind-protect - (progn - (database-execute-command "begin" database) - (setf fd (lo-open ptr object-id postgresql::+INV_READ+)) - (when (>= fd 0) - (setf length (lo-lseek ptr fd 0 2)) - (lo-lseek ptr fd 0 0) - (when (> length 0) - (setf buffer (uffi:allocate-foreign-string - length :unsigned t)) - (when (= (lo-read ptr fd buffer length) length) - (setf result (uffi:convert-from-foreign-string - buffer :length length :null-terminated-p nil)))))) - (progn - (when buffer (uffi:free-foreign-object buffer)) - (when (and fd (>= fd 0)) (lo-close ptr fd)) - (database-execute-command (if result "commit" "rollback") database))) - result)) - -(defmethod database-delete-large-object (object-id (database postgresql-database)) - (lo-unlink (database-conn-ptr database) object-id)) - -(when (clsql-base-sys:database-type-library-loaded :postgresql) - (clsql-base-sys:initialize-database-type :database-type :postgresql) - (pushnew :postgresql cl:*features*)) diff --git a/db-postgresql/postgresql-sql.lisp b/db-postgresql/postgresql-sql.lisp new file mode 100644 index 0000000..3bfac6b --- /dev/null +++ b/db-postgresql/postgresql-sql.lisp @@ -0,0 +1,358 @@ +;;;; -*- 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.lisp,v 1.1 2002/09/30 10:19:23 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-base-sys :postgresql :clsql-uffi) + (:export #:postgresql-database) + (:documentation "This is the CLSQL interface to PostgreSQL.")) + +(in-package :clsql-postgresql) + +;;; Field conversion functions + +(defun make-type-list-for-auto (num-fields res-ptr) + (let ((new-types '())) + (dotimes (i num-fields) + (declare (fixnum i)) + (let* ((type (PQftype res-ptr i))) + (push + (case type + ((#.pgsql-ftype#bytea + #.pgsql-ftype#int2 + #.pgsql-ftype#int4) + :int32) + (#.pgsql-ftype#int8 + :int64) + ((#.pgsql-ftype#float4 + #.pgsql-ftype#float8) + :double) + (otherwise + t)) + new-types))) + (nreverse new-types))) + +(defun canonicalize-types (types num-fields res-ptr) + (if (null types) + nil + (let ((auto-list (make-type-list-for-auto num-fields res-ptr))) + (cond + ((listp types) + (canonicalize-type-list types auto-list)) + ((eq types :auto) + auto-list) + (t + nil))))) + +(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-type ((database postgresql-database)) + :postgresql) + +(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-cstrings ((host-native host) + (user-native user) + (password-native password) + (db-native db) + (port-native port) + (options-native options) + (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) + :connection-spec connection-spec + :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) types) + (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 + (let ((num-fields (PQnfields result))) + (setq types + (canonicalize-types types num-fields + result)) + (loop for tuple-index from 0 below (PQntuples result) + collect + (loop for i from 0 below num-fields + collect + (if (zerop (PQgetisnull result tuple-index i)) + (convert-raw-field + (PQgetvalue result tuple-index i) + types 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) + (types nil) + (num-tuples 0 :type integer) + (num-fields 0 :type integer) + (tuple-index 0 :type integer)) + +(defmethod database-query-result-set (query-expression (database postgresql-database) + &key full-set types) + (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) + (let ((result-set (make-postgresql-result-set + :res-ptr result + :num-fields (PQnfields result) + :num-tuples (PQntuples result) + :types (canonicalize-types + types + (PQnfields result) + result)))) + (if full-set + (values result-set + (PQnfields result) + (PQntuples result)) + (values result-set + (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)) + (types (postgresql-result-set-types 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)) + (convert-raw-field + (PQgetvalue result tuple-index i) + types i) + nil)) + finally + (incf (postgresql-result-set-tuple-index result-set)) + (return list))))) + +;;; Large objects support (Marc B) + +(defmethod database-create-large-object ((database postgresql-database)) + (lo-create (database-conn-ptr database) + (logior postgresql::+INV_WRITE+ postgresql::+INV_READ+))) + + +#+mb-original +(defmethod database-write-large-object (object-id (data string) (database postgresql-database)) + (let ((ptr (database-conn-ptr database)) + (length (length data)) + (result nil) + (fd nil)) + (with-transaction (:database database) + (unwind-protect + (progn + (setf fd (lo-open ptr object-id postgresql::+INV_WRITE+)) + (when (>= fd 0) + (when (= (lo-write ptr fd data length) length) + (setf result t)))) + (progn + (when (and fd (>= fd 0)) + (lo-close ptr fd)) + ))) + result)) + +(defmethod database-write-large-object (object-id (data string) (database postgresql-database)) + (let ((ptr (database-conn-ptr database)) + (length (length data)) + (result nil) + (fd nil)) + (database-execute-command "begin" database) + (unwind-protect + (progn + (setf fd (lo-open ptr object-id postgresql::+INV_WRITE+)) + (when (>= fd 0) + (when (= (lo-write ptr fd data length) length) + (setf result t)))) + (progn + (when (and fd (>= fd 0)) + (lo-close ptr fd)) + (database-execute-command (if result "commit" "rollback") database))) + result)) + +;; (MB) the begin/commit/rollback stuff will be removed when with-transaction wil be implemented +;; (KMR) Can't use with-transaction since that function is in high-level code +(defmethod database-read-large-object (object-id (database postgresql-database)) + (let ((ptr (database-conn-ptr database)) + (buffer nil) + (result nil) + (length 0) + (fd nil)) + (unwind-protect + (progn + (database-execute-command "begin" database) + (setf fd (lo-open ptr object-id postgresql::+INV_READ+)) + (when (>= fd 0) + (setf length (lo-lseek ptr fd 0 2)) + (lo-lseek ptr fd 0 0) + (when (> length 0) + (setf buffer (uffi:allocate-foreign-string + length :unsigned t)) + (when (= (lo-read ptr fd buffer length) length) + (setf result (uffi:convert-from-foreign-string + buffer :length length :null-terminated-p nil)))))) + (progn + (when buffer (uffi:free-foreign-object buffer)) + (when (and fd (>= fd 0)) (lo-close ptr fd)) + (database-execute-command (if result "commit" "rollback") database))) + result)) + +(defmethod database-delete-large-object (object-id (database postgresql-database)) + (lo-unlink (database-conn-ptr database) object-id)) + +(when (clsql-base-sys:database-type-library-loaded :postgresql) + (clsql-base-sys:initialize-database-type :database-type :postgresql) + (pushnew :postgresql cl:*features*)) diff --git a/db-postgresql/postgresql-usql.cl b/db-postgresql/postgresql-usql.cl deleted file mode 100644 index 6d63260..0000000 --- a/db-postgresql/postgresql-usql.cl +++ /dev/null @@ -1,108 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: postgresql-usql.sql -;;;; Purpose: PostgreSQL interface for USQL routines -;;;; Programmers: Kevin M. Rosenberg and onShore Development Inc -;;;; Date Started: Mar 2002 -;;;; -;;;; $Id: postgresql-usql.cl,v 1.1 2002/09/18 07:43:41 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; and by onShore Development Inc. -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-postgresql) - -(defmethod database-list-tables ((database postgresql-database) - &key (system-tables nil)) - (let ((res (mapcar #'car (database-query - "SELECT tablename FROM pg_tables" - database nil)))) - (if (not system-tables) - (remove-if #'(lambda (table) - (equal (subseq table 0 3) - "pg_")) res) - res))) - - - -(defmethod database-list-attributes ((table string) - (database postgresql-database)) - (let* ((result - (mapcar #'car - (database-query - (format nil - "SELECT attname FROM pg_class,pg_attribute WHERE pg_class.oid=attrelid AND relname='~A'" table) - database nil)))) - (if result - (reverse - (remove-if #'(lambda (it) (member it '("cmin" - "cmax" - "xmax" - "xmin" - "oid" - "ctid" - ;; kmr -- added tableoid - "tableoid") :test #'equal)) - result))))) - -(defmethod database-attribute-type (attribute (table string) - (database postgresql-database)) - (let ((result - (mapcar #'car - (database-query - (format nil - "SELECT pg_type.typname FROM pg_type,pg_class,pg_attribute WHERE pg_class.oid=pg_attribute.attrelid AND pg_class.relname='~A' AND pg_attribute.attname='~A' AND pg_attribute.atttypid=pg_type.oid" - table attribute) - database nil)))) - (if result - (intern (string-upcase (car result)) :keyword) nil))) - - -(defmethod database-create-sequence (sequence-name - (database postgresql-database)) - (database-execute-command - (concatenate 'string "CREATE SEQUENCE " (sql-escape sequence-name)) database)) - -(defmethod database-drop-sequence (sequence-name - (database postgresql-database)) - (database-execute-command - (concatenate 'string "DROP SEQUENCE " (sql-escape sequence-name)) database)) - -(defmethod database-sequence-next (sequence-name - (database postgresql-database)) - (parse-integer - (caar - (database-query - (concatenate 'string "SELECT NEXTVAL ('" (sql-escape sequence-name) "')") - database nil)))) - -;; Functions depending upon high-level USQL classes/functions - -#| -(defmethod database-output-sql ((expr clsql-sys::sql-typecast-exp) - (database postgresql-database)) - (with-slots (clsql-sys::modifier clsql-sys::components) - expr - (if clsql-sys::modifier - (progn - (clsql-sys::output-sql clsql-sys::components database) - (write-char #\: clsql-sys::*sql-stream*) - (write-char #\: clsql-sys::*sql-stream*) - (write-string (symbol-name clsql-sys::modifier) - clsql-sys::*sql-stream*))))) - -(defmethod database-output-sql-as-type ((type (eql 'integer)) val - (database postgresql-database)) - (when val ;; typecast it so it uses the indexes - (make-instance 'clsql-sys::sql-typecast-exp - :modifier 'int8 - :components val))) -|# diff --git a/db-postgresql/postgresql-usql.lisp b/db-postgresql/postgresql-usql.lisp new file mode 100644 index 0000000..bdf6938 --- /dev/null +++ b/db-postgresql/postgresql-usql.lisp @@ -0,0 +1,108 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: postgresql-usql.sql +;;;; Purpose: PostgreSQL interface for USQL routines +;;;; Programmers: Kevin M. Rosenberg and onShore Development Inc +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id: postgresql-usql.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; and by onShore Development Inc. +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :clsql-postgresql) + +(defmethod database-list-tables ((database postgresql-database) + &key (system-tables nil)) + (let ((res (mapcar #'car (database-query + "SELECT tablename FROM pg_tables" + database nil)))) + (if (not system-tables) + (remove-if #'(lambda (table) + (equal (subseq table 0 3) + "pg_")) res) + res))) + + + +(defmethod database-list-attributes ((table string) + (database postgresql-database)) + (let* ((result + (mapcar #'car + (database-query + (format nil + "SELECT attname FROM pg_class,pg_attribute WHERE pg_class.oid=attrelid AND relname='~A'" table) + database nil)))) + (if result + (reverse + (remove-if #'(lambda (it) (member it '("cmin" + "cmax" + "xmax" + "xmin" + "oid" + "ctid" + ;; kmr -- added tableoid + "tableoid") :test #'equal)) + result))))) + +(defmethod database-attribute-type (attribute (table string) + (database postgresql-database)) + (let ((result + (mapcar #'car + (database-query + (format nil + "SELECT pg_type.typname FROM pg_type,pg_class,pg_attribute WHERE pg_class.oid=pg_attribute.attrelid AND pg_class.relname='~A' AND pg_attribute.attname='~A' AND pg_attribute.atttypid=pg_type.oid" + table attribute) + database nil)))) + (if result + (intern (string-upcase (car result)) :keyword) nil))) + + +(defmethod database-create-sequence (sequence-name + (database postgresql-database)) + (database-execute-command + (concatenate 'string "CREATE SEQUENCE " (sql-escape sequence-name)) database)) + +(defmethod database-drop-sequence (sequence-name + (database postgresql-database)) + (database-execute-command + (concatenate 'string "DROP SEQUENCE " (sql-escape sequence-name)) database)) + +(defmethod database-sequence-next (sequence-name + (database postgresql-database)) + (parse-integer + (caar + (database-query + (concatenate 'string "SELECT NEXTVAL ('" (sql-escape sequence-name) "')") + database nil)))) + +;; Functions depending upon high-level USQL classes/functions + +#| +(defmethod database-output-sql ((expr clsql-sys::sql-typecast-exp) + (database postgresql-database)) + (with-slots (clsql-sys::modifier clsql-sys::components) + expr + (if clsql-sys::modifier + (progn + (clsql-sys::output-sql clsql-sys::components database) + (write-char #\: clsql-sys::*sql-stream*) + (write-char #\: clsql-sys::*sql-stream*) + (write-string (symbol-name clsql-sys::modifier) + clsql-sys::*sql-stream*))))) + +(defmethod database-output-sql-as-type ((type (eql 'integer)) val + (database postgresql-database)) + (when val ;; typecast it so it uses the indexes + (make-instance 'clsql-sys::sql-typecast-exp + :modifier 'int8 + :components val))) +|# diff --git a/debian/changelog b/debian/changelog index f275385..6a8f828 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-sql (0.9.8-1) unstable; urgency=low + + * Rename .cl files to .lisp files + + -- Kevin M. Rosenberg Mon, 30 Sep 2002 04:08:25 -0600 + cl-sql (0.9.7-1) unstable; urgency=low * base/conditions.cl: Fix format string error diff --git a/debian/rules b/debian/rules index 71b979e..222f0ff 100755 --- a/debian/rules +++ b/debian/rules @@ -23,15 +23,15 @@ all-pkgs := $(pkg) $(pkg-base) $(pkg-uffi) $(pkg-mysql) $(pkg-pg) $(pkg-pg-socke UPSTREAM_VER := $(shell sed -n -e "s/${pkg} (\(.*\)-[0-9A-Za-z\.]).*/\1/p" < debian/changelog |head -1) ## Lisp sources -srcs := $(wildcard sql/*.cl) clsql.asd -srcs-base := $(wildcard base/*.cl) -srcs-uffi := $(wildcard uffi/*.cl) $(wildcard uffi/*.c) +srcs := $(wildcard sql/*.lisp) clsql.asd +srcs-base := $(wildcard base/*.lisp) +srcs-uffi := $(wildcard uffi/*.lisp) $(wildcard uffi/*.c) srcs-uffi-so := $(wildcard uffi/*.so) -srcs-mysql := $(wildcard db-mysql/*.cl) $(wildcard db-mysql/*.c) +srcs-mysql := $(wildcard db-mysql/*.lisp) $(wildcard db-mysql/*.c) srcs-mysql-so := $(wildcard db-mysql/*.so) -srcs-pg := $(wildcard db-postgresql/*.cl) -srcs-pg-socket := $(wildcard db-postgresql-socket/*.cl) -srcs-aodbc := $(wildcard db-aodbc/*.cl) +srcs-pg := $(wildcard db-postgresql/*.lisp) +srcs-pg-socket := $(wildcard db-postgresql-socket/*.lisp) +srcs-aodbc := $(wildcard db-aodbc/*.lisp) clc-base := usr/share/common-lisp clc-source := $(clc-base)/source @@ -129,7 +129,7 @@ install: build # Test suite dh_installdirs -p $(pkg) $(doc-dir)/html $(doc-dir)/test-suite - dh_install -p $(pkg) test-suite/tester-clsql.cl test-suite/acl-compat-tester.cl $(doc-dir)/test-suite + dh_install -p $(pkg) test-suite/tester-clsql.lisp test-suite/acl-compat-tester.lisp $(doc-dir)/test-suite # Documentation rm -rf doc/html diff --git a/sql/functional.cl b/sql/functional.cl deleted file mode 100644 index e283e5d..0000000 --- a/sql/functional.cl +++ /dev/null @@ -1,99 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: functional.cl -;;;; Purpose: Functional interface -;;;; Programmer: Pierre R. Mai -;;;; -;;;; Copyright (c) 1999-2001 Pierre R. Mai -;;;; -;;;; $Id: functional.cl,v 1.8 2002/09/17 17:16:43 kevin Exp $ -;;;; -;;;; This file is part of CLSQL. -;;;; -;;;; CLSQL is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License (version 2) as -;;;; published by the Free Software Foundation. -;;;; -;;;; CLSQL is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with CLSQL; if not, write to the Free Software Foundation, Inc., -;;;; 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-sys) - - -;;;; This file implements the more advanced functions of the -;;;; functional SQL interface, which are just nicer layers above the -;;;; basic SQL interface. - -(defun insert-records - (&key into attributes values av-pairs query (database *default-database*)) - "Insert records into the given table according to the given options." - (cond - ((and av-pairs (or attributes values)) - (error "Supply either av-pairs or values (and possibly attributes) to call of insert-records.")) - ((and (or av-pairs values) query) - (error - "Supply either query or values/av-pairs to call of insert-records.")) - ((and attributes (not query) - (or (not (listp values)) (/= (length attributes) (length values)))) - (error "You must supply a matching values list when using attributes in call of insert-records.")) - (query - (execute-command - (format nil "insert into ~A ~@[(~{~A~^,~}) ~]~A" into attributes query) - :database database)) - (t - (execute-command - (multiple-value-bind (attributes values) - (if av-pairs - (values (mapcar #'first av-pairs) (mapcar #'second av-pairs)) - (values attributes values)) - (format nil "insert into ~A ~@[(~{~A~^,~}) ~]values (~{'~A'~^,~})" - into attributes values)) - :database database)))) - -(defun delete-records (&key from where (database *default-database*)) - "Delete the indicated records from the given database." - (execute-command (format nil "delete from ~A ~@[where ~A ~]" from where) - :database database)) - -(defun update-records (table &key attributes values av-pairs where (database *default-database*)) - "Update the specified records in the given database." - (cond - ((and av-pairs (or attributes values)) - (error "Supply either av-pairs or values (and possibly attributes) to call of update-records.")) - ((and attributes - (or (not (listp values)) (/= (length attributes) (length values)))) - (error "You must supply a matching values list when using attributes in call of update-records.")) - ((or (and attributes (not values)) (and values (not attributes))) - (error "You must supply both values and attributes in call of update-records.")) - (t - (execute-command - (format nil "update ~A set ~:{~A = '~A'~:^, ~}~@[ where ~A~]" - table - (or av-pairs - (mapcar #'list attributes values)) - where) - :database database)))) - -(defmacro with-database ((db-var connection-spec &rest connect-args) &body body) - "Evaluate the body in an environment, where `db-var' is bound to the -database connection given by `connection-spec' and `connect-args'. -The connection is automatically closed or released to the pool on exit from the body." - (let ((result (gensym "result-"))) - (unless db-var (setf db-var '*default-database*)) - `(let ((,db-var (connect ,connection-spec ,@connect-args)) - (,result nil)) - (unwind-protect - (let ((,db-var ,db-var)) - (setf ,result (progn ,@body))) - (disconnect :database ,db-var)) - ,result))) \ No newline at end of file diff --git a/sql/functional.lisp b/sql/functional.lisp new file mode 100644 index 0000000..125bb71 --- /dev/null +++ b/sql/functional.lisp @@ -0,0 +1,99 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: functional.cl +;;;; Purpose: Functional interface +;;;; Programmer: Pierre R. Mai +;;;; +;;;; Copyright (c) 1999-2001 Pierre R. Mai +;;;; +;;;; $Id: functional.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $ +;;;; +;;;; This file is part of CLSQL. +;;;; +;;;; CLSQL is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License (version 2) as +;;;; published by the Free Software Foundation. +;;;; +;;;; CLSQL is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with CLSQL; if not, write to the Free Software Foundation, Inc., +;;;; 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :clsql-sys) + + +;;;; This file implements the more advanced functions of the +;;;; functional SQL interface, which are just nicer layers above the +;;;; basic SQL interface. + +(defun insert-records + (&key into attributes values av-pairs query (database *default-database*)) + "Insert records into the given table according to the given options." + (cond + ((and av-pairs (or attributes values)) + (error "Supply either av-pairs or values (and possibly attributes) to call of insert-records.")) + ((and (or av-pairs values) query) + (error + "Supply either query or values/av-pairs to call of insert-records.")) + ((and attributes (not query) + (or (not (listp values)) (/= (length attributes) (length values)))) + (error "You must supply a matching values list when using attributes in call of insert-records.")) + (query + (execute-command + (format nil "insert into ~A ~@[(~{~A~^,~}) ~]~A" into attributes query) + :database database)) + (t + (execute-command + (multiple-value-bind (attributes values) + (if av-pairs + (values (mapcar #'first av-pairs) (mapcar #'second av-pairs)) + (values attributes values)) + (format nil "insert into ~A ~@[(~{~A~^,~}) ~]values (~{'~A'~^,~})" + into attributes values)) + :database database)))) + +(defun delete-records (&key from where (database *default-database*)) + "Delete the indicated records from the given database." + (execute-command (format nil "delete from ~A ~@[where ~A ~]" from where) + :database database)) + +(defun update-records (table &key attributes values av-pairs where (database *default-database*)) + "Update the specified records in the given database." + (cond + ((and av-pairs (or attributes values)) + (error "Supply either av-pairs or values (and possibly attributes) to call of update-records.")) + ((and attributes + (or (not (listp values)) (/= (length attributes) (length values)))) + (error "You must supply a matching values list when using attributes in call of update-records.")) + ((or (and attributes (not values)) (and values (not attributes))) + (error "You must supply both values and attributes in call of update-records.")) + (t + (execute-command + (format nil "update ~A set ~:{~A = '~A'~:^, ~}~@[ where ~A~]" + table + (or av-pairs + (mapcar #'list attributes values)) + where) + :database database)))) + +(defmacro with-database ((db-var connection-spec &rest connect-args) &body body) + "Evaluate the body in an environment, where `db-var' is bound to the +database connection given by `connection-spec' and `connect-args'. +The connection is automatically closed or released to the pool on exit from the body." + (let ((result (gensym "result-"))) + (unless db-var (setf db-var '*default-database*)) + `(let ((,db-var (connect ,connection-spec ,@connect-args)) + (,result nil)) + (unwind-protect + (let ((,db-var ,db-var)) + (setf ,result (progn ,@body))) + (disconnect :database ,db-var)) + ,result))) \ No newline at end of file diff --git a/sql/loop-extension.cl b/sql/loop-extension.cl deleted file mode 100644 index 6b59250..0000000 --- a/sql/loop-extension.cl +++ /dev/null @@ -1,98 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: loop-extension.cl -;;;; Purpose: Extensions to the Loop macro for CMUCL -;;;; Programmer: Pierre R. Mai -;;;; -;;;; Copyright (c) 1999-2001 Pierre R. Mai -;;;; -;;;; $Id: loop-extension.cl,v 1.3 2002/09/17 17:16:43 kevin Exp $ -;;;; -;;;; The functions in this file were orignally distributed in the -;;;; MaiSQL package in the file sql/sql.cl -;;;; ************************************************************************* - -(in-package :cl-user) - -;;;; MIT-LOOP extension - -#+cmu -(defun loop-record-iteration-path (variable data-type prep-phrases) - (let ((in-phrase nil) - (from-phrase nil)) - (loop for (prep . rest) in prep-phrases - do - (case prep - ((:in :of) - (when in-phrase - (ansi-loop::loop-error - "Duplicate OF or IN iteration path: ~S." (cons prep rest))) - (setq in-phrase rest)) - ((:from) - (when from-phrase - (ansi-loop::loop-error - "Duplicate FROM iteration path: ~S." (cons prep rest))) - (setq from-phrase rest)) - (t - (ansi-loop::loop-error - "Unknown preposition: ~S." prep)))) - (unless in-phrase - (ansi-loop::loop-error "Missing OF or IN iteration path.")) - (unless from-phrase - (setq from-phrase '(*default-database*))) - (cond - ((consp variable) - (let ((query-var (ansi-loop::loop-gentemp 'loop-record-)) - (db-var (ansi-loop::loop-gentemp 'loop-record-database-)) - (result-set-var (ansi-loop::loop-gentemp - 'loop-record-result-set-)) - (step-var (ansi-loop::loop-gentemp 'loop-record-step-))) - (push `(when ,result-set-var - (database-dump-result-set ,result-set-var ,db-var)) - ansi-loop::*loop-epilogue*) - `(((,variable nil ,data-type) (,query-var ,(first in-phrase)) - (,db-var ,(first from-phrase)) - (,result-set-var nil) - (,step-var nil)) - ((multiple-value-bind (%rs %cols) - (database-query-result-set ,query-var ,db-var) - (setq ,result-set-var %rs ,step-var (make-list %cols)))) - () - () - (not (database-store-next-row ,result-set-var ,db-var ,step-var)) - (,variable ,step-var) - (not ,result-set-var) - () - (not (database-store-next-row ,result-set-var ,db-var ,step-var)) - (,variable ,step-var)))) - (t - (let ((query-var (ansi-loop::loop-gentemp 'loop-record-)) - (db-var (ansi-loop::loop-gentemp 'loop-record-database-)) - (result-set-var (ansi-loop::loop-gentemp - 'loop-record-result-set-))) - (push `(when ,result-set-var - (database-dump-result-set ,result-set-var ,db-var)) - ansi-loop::*loop-epilogue*) - `(((,variable nil ,data-type) (,query-var ,(first in-phrase)) - (,db-var ,(first from-phrase)) - (,result-set-var nil)) - ((multiple-value-bind (%rs %cols) - (database-query-result-set ,query-var ,db-var) - (setq ,result-set-var %rs ,variable (make-list %cols)))) - () - () - (not (database-store-next-row ,result-set-var ,db-var ,variable)) - () - (not ,result-set-var) - () - (not (database-store-next-row ,result-set-var ,db-var ,variable)) - ())))))) - -#+cmu -(ansi-loop::add-loop-path '(record records tuple tuples) - 'loop-record-iteration-path - ansi-loop::*loop-ansi-universe* - :preposition-groups '((:of :in) (:from)) - :inclusive-permitted nil) diff --git a/sql/loop-extension.lisp b/sql/loop-extension.lisp new file mode 100644 index 0000000..d19dfb6 --- /dev/null +++ b/sql/loop-extension.lisp @@ -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.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $ +;;;; +;;;; The functions in this file were orignally distributed in the +;;;; MaiSQL package in the file sql/sql.cl +;;;; ************************************************************************* + +(in-package :cl-user) + +;;;; MIT-LOOP extension + +#+cmu +(defun loop-record-iteration-path (variable data-type prep-phrases) + (let ((in-phrase nil) + (from-phrase nil)) + (loop for (prep . rest) in prep-phrases + do + (case prep + ((:in :of) + (when in-phrase + (ansi-loop::loop-error + "Duplicate OF or IN iteration path: ~S." (cons prep rest))) + (setq in-phrase rest)) + ((:from) + (when from-phrase + (ansi-loop::loop-error + "Duplicate FROM iteration path: ~S." (cons prep rest))) + (setq from-phrase rest)) + (t + (ansi-loop::loop-error + "Unknown preposition: ~S." prep)))) + (unless in-phrase + (ansi-loop::loop-error "Missing OF or IN iteration path.")) + (unless from-phrase + (setq from-phrase '(*default-database*))) + (cond + ((consp variable) + (let ((query-var (ansi-loop::loop-gentemp 'loop-record-)) + (db-var (ansi-loop::loop-gentemp 'loop-record-database-)) + (result-set-var (ansi-loop::loop-gentemp + 'loop-record-result-set-)) + (step-var (ansi-loop::loop-gentemp 'loop-record-step-))) + (push `(when ,result-set-var + (database-dump-result-set ,result-set-var ,db-var)) + ansi-loop::*loop-epilogue*) + `(((,variable nil ,data-type) (,query-var ,(first in-phrase)) + (,db-var ,(first from-phrase)) + (,result-set-var nil) + (,step-var nil)) + ((multiple-value-bind (%rs %cols) + (database-query-result-set ,query-var ,db-var) + (setq ,result-set-var %rs ,step-var (make-list %cols)))) + () + () + (not (database-store-next-row ,result-set-var ,db-var ,step-var)) + (,variable ,step-var) + (not ,result-set-var) + () + (not (database-store-next-row ,result-set-var ,db-var ,step-var)) + (,variable ,step-var)))) + (t + (let ((query-var (ansi-loop::loop-gentemp 'loop-record-)) + (db-var (ansi-loop::loop-gentemp 'loop-record-database-)) + (result-set-var (ansi-loop::loop-gentemp + 'loop-record-result-set-))) + (push `(when ,result-set-var + (database-dump-result-set ,result-set-var ,db-var)) + ansi-loop::*loop-epilogue*) + `(((,variable nil ,data-type) (,query-var ,(first in-phrase)) + (,db-var ,(first from-phrase)) + (,result-set-var nil)) + ((multiple-value-bind (%rs %cols) + (database-query-result-set ,query-var ,db-var) + (setq ,result-set-var %rs ,variable (make-list %cols)))) + () + () + (not (database-store-next-row ,result-set-var ,db-var ,variable)) + () + (not ,result-set-var) + () + (not (database-store-next-row ,result-set-var ,db-var ,variable)) + ())))))) + +#+cmu +(ansi-loop::add-loop-path '(record records tuple tuples) + 'loop-record-iteration-path + ansi-loop::*loop-ansi-universe* + :preposition-groups '((:of :in) (:from)) + :inclusive-permitted nil) diff --git a/sql/package.cl b/sql/package.cl deleted file mode 100644 index 2bb0d8e..0000000 --- a/sql/package.cl +++ /dev/null @@ -1,133 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: package.cl -;;;; Purpose: Package definition for CLSQL (high-level) interface -;;;; Programmers: Kevin M. Rosenberg based on -;;;; Original code by Pierre R. Mai -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: package.cl,v 1.19 2002/09/17 17:16:43 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; and Copyright (c) 1999-2001 by Pierre R. Mai -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :cl-user) - - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defpackage :clsql-sys - (:nicknames :clsql) - (:use :common-lisp :clsql-base-sys) - (:import-from - :clsql-base - . - #1=( - #:clsql-condition - #:clsql-error - #:clsql-simple-error - #:clsql-warning - #:clsql-simple-warning - #:clsql-invalid-spec-error - #:clsql-invalid-spec-error-connection-spec - #:clsql-invalid-spec-error-database-type - #:clsql-invalid-spec-error-template - #:clsql-connect-error - #:clsql-connect-error-database-type - #:clsql-connect-error-connection-spec - #:clsql-connect-error-errno - #:clsql-connect-error-error - #:clsql-sql-error - #:clsql-sql-error-database - #:clsql-sql-error-expression - #:clsql-sql-error-errno - #:clsql-sql-error-error - #:clsql-database-warning - #:clsql-database-warning-database - #:clsql-database-warning-message - #:clsql-exists-condition - #:clsql-exists-condition-new-db - #:clsql-exists-condition-old-db - #:clsql-exists-warning - #:clsql-exists-error - #:clsql-closed-error - #:clsql-closed-error-database - - #:*loaded-database-types* - #:reload-database-types - #:*default-database-type* - #:*initialized-database-types* - #:initialize-database-type - - #:database - #:database-name - #:closed-database - #:database-name-from-spec - - ;; utils.cl - #:number-to-sql-string - #:float-to-sql-string - #:sql-escape-quotes - )) - (:export - ;; sql.cl - #:*connect-if-exists* - #:connected-databases - #:*default-database* - #:find-database - #:connect - #:disconnect - #:query - #:execute-command - #:map-query - #:do-query - - ;; functional.cl - #:insert-records - #:delete-records - #:update-records - #:with-database - - ;; For High-level UncommonSQL compatibility - #:sql-ident - #:list-tables - #:list-attributes - #:attribute-type - #:create-sequence - #:drop-sequence - #:sequence-next - - ;; Pooled connections - #:disconnect-pooled - #:find-or-create-connection-pool - - ;; Transactions - #:with-transaction - #:commit-transaction - #:rollback-transaction - #:add-transaction-commit-hook - #:add-transaction-rollback-hook - - ;; Large objects (Marc B) - #:create-large-object - #:write-large-object - #:read-large-object - #:delete-large-object - - . - #1# - ) - (:documentation "This is the INTERNAL SQL-Interface package of CLSQL.")) - - ) ;eval-when - -(defpackage #:clsql-user - (:use #:common-lisp #:clsql) - (:documentation "This is the user package for experimenting with CLSQL.")) diff --git a/sql/package.lisp b/sql/package.lisp new file mode 100644 index 0000000..dd3e5dd --- /dev/null +++ b/sql/package.lisp @@ -0,0 +1,133 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: package.cl +;;;; Purpose: Package definition for CLSQL (high-level) interface +;;;; Programmers: Kevin M. Rosenberg based on +;;;; Original code by Pierre R. Mai +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: package.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; and Copyright (c) 1999-2001 by Pierre R. Mai +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :cl-user) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defpackage :clsql-sys + (:nicknames :clsql) + (:use :common-lisp :clsql-base-sys) + (:import-from + :clsql-base + . + #1=( + #:clsql-condition + #:clsql-error + #:clsql-simple-error + #:clsql-warning + #:clsql-simple-warning + #:clsql-invalid-spec-error + #:clsql-invalid-spec-error-connection-spec + #:clsql-invalid-spec-error-database-type + #:clsql-invalid-spec-error-template + #:clsql-connect-error + #:clsql-connect-error-database-type + #:clsql-connect-error-connection-spec + #:clsql-connect-error-errno + #:clsql-connect-error-error + #:clsql-sql-error + #:clsql-sql-error-database + #:clsql-sql-error-expression + #:clsql-sql-error-errno + #:clsql-sql-error-error + #:clsql-database-warning + #:clsql-database-warning-database + #:clsql-database-warning-message + #:clsql-exists-condition + #:clsql-exists-condition-new-db + #:clsql-exists-condition-old-db + #:clsql-exists-warning + #:clsql-exists-error + #:clsql-closed-error + #:clsql-closed-error-database + + #:*loaded-database-types* + #:reload-database-types + #:*default-database-type* + #:*initialized-database-types* + #:initialize-database-type + + #:database + #:database-name + #:closed-database + #:database-name-from-spec + + ;; utils.cl + #:number-to-sql-string + #:float-to-sql-string + #:sql-escape-quotes + )) + (:export + ;; sql.cl + #:*connect-if-exists* + #:connected-databases + #:*default-database* + #:find-database + #:connect + #:disconnect + #:query + #:execute-command + #:map-query + #:do-query + + ;; functional.cl + #:insert-records + #:delete-records + #:update-records + #:with-database + + ;; For High-level UncommonSQL compatibility + #:sql-ident + #:list-tables + #:list-attributes + #:attribute-type + #:create-sequence + #:drop-sequence + #:sequence-next + + ;; Pooled connections + #:disconnect-pooled + #:find-or-create-connection-pool + + ;; Transactions + #:with-transaction + #:commit-transaction + #:rollback-transaction + #:add-transaction-commit-hook + #:add-transaction-rollback-hook + + ;; Large objects (Marc B) + #:create-large-object + #:write-large-object + #:read-large-object + #:delete-large-object + + . + #1# + ) + (:documentation "This is the INTERNAL SQL-Interface package of CLSQL.")) + + ) ;eval-when + +(defpackage #:clsql-user + (:use #:common-lisp #:clsql) + (:documentation "This is the user package for experimenting with CLSQL.")) diff --git a/sql/pool.cl b/sql/pool.cl deleted file mode 100644 index f4d965c..0000000 --- a/sql/pool.cl +++ /dev/null @@ -1,79 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: pool.cl -;;;; Purpose: Support function for connection pool -;;;; Programmers: Kevin M. Rosenberg, Marc Battyani -;;;; Date Started: Apr 2002 -;;;; -;;;; $Id: pool.cl,v 1.8 2002/09/17 17:16:43 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-sys) - -(defvar *db-pool* (make-hash-table :test #'equal)) - -(defclass conn-pool () - ((connection-spec :accessor connection-spec :initarg :connection-spec) - (database-type :accessor database-type :initarg :database-type) - (free-connections :accessor free-connections - :initform (make-array 5 :fill-pointer 0 :adjustable t)) - (all-connections :accessor all-connections - :initform (make-array 5 :fill-pointer 0 :adjustable t)))) - -(defun acquire-from-conn-pool (pool) - (if (zerop (length (free-connections pool))) - (let ((conn (connect (connection-spec pool) - :database-type (database-type pool) :if-exists :new))) - (vector-push-extend conn (all-connections pool)) - (setf (conn-pool conn) pool) - conn) - (vector-pop (free-connections pool)))) - -(defun release-to-conn-pool (conn) - (vector-push-extend conn (free-connections (conn-pool conn)))) - -(defun clear-conn-pool (pool) - (loop for conn across (all-connections pool) - do (setf (conn-pool conn) nil) - (disconnect :database conn)) - (setf (fill-pointer (free-connections pool)) 0) - (setf (fill-pointer (all-connections pool)) 0)) - -(defun find-or-create-connection-pool (connection-spec database-type) - "Find connection pool in hash table, creates a new connection pool if not found" - (let* ((key (list connection-spec database-type)) - (conn-pool (gethash key *db-pool*))) - (unless conn-pool - (setq conn-pool (make-instance 'conn-pool - :connection-spec connection-spec - :database-type database-type)) - (setf (gethash key *db-pool*) conn-pool)) - conn-pool)) - -(defun acquire-from-pool (connection-spec database-type &optional pool) - (unless (typep pool 'conn-pool) - (setf pool (find-or-create-connection-pool connection-spec database-type))) - (acquire-from-conn-pool pool)) - -(defun release-to-pool (database) - (release-to-conn-pool database)) - -(defun disconnect-pooled (&optional clear) - "Disconnects all connections in the pool" - (maphash - #'(lambda (key conn-pool) - (declare (ignore key)) - (clear-conn-pool conn-pool)) - *db-pool*) - (when clear (clrhash *db-pool*)) - t) - diff --git a/sql/pool.lisp b/sql/pool.lisp new file mode 100644 index 0000000..1a556d8 --- /dev/null +++ b/sql/pool.lisp @@ -0,0 +1,79 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: pool.cl +;;;; Purpose: Support function for connection pool +;;;; Programmers: Kevin M. Rosenberg, Marc Battyani +;;;; Date Started: Apr 2002 +;;;; +;;;; $Id: pool.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :clsql-sys) + +(defvar *db-pool* (make-hash-table :test #'equal)) + +(defclass conn-pool () + ((connection-spec :accessor connection-spec :initarg :connection-spec) + (database-type :accessor database-type :initarg :database-type) + (free-connections :accessor free-connections + :initform (make-array 5 :fill-pointer 0 :adjustable t)) + (all-connections :accessor all-connections + :initform (make-array 5 :fill-pointer 0 :adjustable t)))) + +(defun acquire-from-conn-pool (pool) + (if (zerop (length (free-connections pool))) + (let ((conn (connect (connection-spec pool) + :database-type (database-type pool) :if-exists :new))) + (vector-push-extend conn (all-connections pool)) + (setf (conn-pool conn) pool) + conn) + (vector-pop (free-connections pool)))) + +(defun release-to-conn-pool (conn) + (vector-push-extend conn (free-connections (conn-pool conn)))) + +(defun clear-conn-pool (pool) + (loop for conn across (all-connections pool) + do (setf (conn-pool conn) nil) + (disconnect :database conn)) + (setf (fill-pointer (free-connections pool)) 0) + (setf (fill-pointer (all-connections pool)) 0)) + +(defun find-or-create-connection-pool (connection-spec database-type) + "Find connection pool in hash table, creates a new connection pool if not found" + (let* ((key (list connection-spec database-type)) + (conn-pool (gethash key *db-pool*))) + (unless conn-pool + (setq conn-pool (make-instance 'conn-pool + :connection-spec connection-spec + :database-type database-type)) + (setf (gethash key *db-pool*) conn-pool)) + conn-pool)) + +(defun acquire-from-pool (connection-spec database-type &optional pool) + (unless (typep pool 'conn-pool) + (setf pool (find-or-create-connection-pool connection-spec database-type))) + (acquire-from-conn-pool pool)) + +(defun release-to-pool (database) + (release-to-conn-pool database)) + +(defun disconnect-pooled (&optional clear) + "Disconnects all connections in the pool" + (maphash + #'(lambda (key conn-pool) + (declare (ignore key)) + (clear-conn-pool conn-pool)) + *db-pool*) + (when clear (clrhash *db-pool*)) + t) + diff --git a/sql/sql.cl b/sql/sql.cl deleted file mode 100644 index 101d30f..0000000 --- a/sql/sql.cl +++ /dev/null @@ -1,262 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: sql.cl -;;;; Purpose: High-level SQL interface -;;;; Programmers: Kevin M. Rosenberg based on -;;;; Original code by Pierre R. Mai -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: sql.cl,v 1.19 2002/09/17 17:16:43 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; and Copyright (c) 1999-2001 by Pierre R. Mai -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-sys) - -;;; Modified by KMR -;;; - to use CMUCL-COMPAT library -;;; - fix format strings in error messages -;;; - use field types - - -;;; Simple implementation of SQL along the lines of Harlequin's Common SQL - - -;;; Database handling - -(defvar *connect-if-exists* :error - "Default value for the if-exists parameter of connect calls.") - -(defvar *connected-databases* nil - "List of active database objects.") - -(defun connected-databases () - "Return the list of active database objects." - *connected-databases*) - -(defvar *default-database* nil - "Specifies the default database to be used.") - -(defun find-database (database &optional (errorp t)) - (etypecase database - (database - ;; Return the database object itself - database) - (string - (or (find database (connected-databases) - :key #'database-name - :test #'string=) - (when errorp - (cerror "Return nil." - 'clsql-simple-error - :format-control "There exists no database called ~A." - :format-arguments (list database))))))) - -(defun connect (connection-spec - &key (if-exists *connect-if-exists*) - (database-type *default-database-type*) - (pool nil)) - "Connects to a database of the given database-type, using the type-specific -connection-spec. if-exists is currently ignored. -If pool is t the the connection will be taken from the general pool, -if pool is a conn-pool object the connection will be taken from this pool. -" - (if pool - (acquire-from-pool connection-spec database-type pool) - (let* ((db-name (database-name-from-spec connection-spec database-type)) - (old-db (unless (eq if-exists :new) (find-database db-name nil))) - (result nil)) - (if old-db - (case if-exists -; (:new -; (setq result -; (database-connect connection-spec database-type))) - (:warn-new - (setq result - (database-connect connection-spec database-type)) - (warn 'clsql-exists-warning :old-db old-db :new-db result)) - (:error - (restart-case - (error 'clsql-exists-error :old-db old-db) - (create-new () - :report "Create a new connection." - (setq result - (database-connect connection-spec database-type))) - (use-old () - :report "Use the existing connection." - (setq result old-db)))) - (:warn-old - (setq result old-db) - (warn 'clsql-exists-warning :old-db old-db :new-db old-db)) - (:old - (setq result old-db))) - (setq result - (database-connect connection-spec database-type))) - (when result - (pushnew result *connected-databases*) - (setq *default-database* result) - result)))) - - -(defun disconnect (&key (database *default-database*)) - "Closes the connection to database. Resets *default-database* if that -database was disconnected and only one other connection exists. -if the database is from a pool it will be released to this pool." - (if (conn-pool database) - (release-to-pool database) - (when (database-disconnect database) - (setq *connected-databases* (delete database *connected-databases*)) - (when (eq database *default-database*) - (setq *default-database* (car *connected-databases*))) - (change-class database 'closed-database) - t))) - -;;; Basic operations on databases - -(defmethod query (query-expression &key (database *default-database*) - types) - "Execute the SQL query expression query-expression on the given database. -Returns a list of lists of values of the result of that expression." - (database-query query-expression database types)) - - - -(defmethod execute-command (sql-expression &key (database *default-database*)) - "Execute the SQL command expression sql-expression on the given database. -Returns true on success or nil on failure." - (database-execute-command sql-expression database)) - - - -(defun map-query (output-type-spec function query-expression - &key (database *default-database*) - (types nil)) - "Map the function over all tuples that are returned by the query in -query-expression. The results of the function are collected as -specified in output-type-spec and returned like in MAP." - ;; DANGER Will Robinson: Parts of the code for implementing - ;; map-query (including the code below and the helper functions - ;; called) are highly CMU CL specific. - ;; KMR -- these have been replaced with cross-platform instructions above - (macrolet ((type-specifier-atom (type) - `(if (atom ,type) ,type (car ,type)))) - (case (type-specifier-atom output-type-spec) - ((nil) - (map-query-for-effect function query-expression database types)) - (list - (map-query-to-list function query-expression database types)) - ((simple-vector simple-string vector string array simple-array - bit-vector simple-bit-vector base-string - simple-base-string) - (map-query-to-simple output-type-spec function query-expression database types)) - (t - (funcall #'map-query (cmucl-compat:result-type-or-lose output-type-spec t) - function query-expression :database database :types types))))) - -(defun map-query-for-effect (function query-expression database types) - (multiple-value-bind (result-set columns) - (database-query-result-set query-expression database :full-set nil - :types types) - (when result-set - (unwind-protect - (do ((row (make-list columns))) - ((not (database-store-next-row result-set database row)) - nil) - (apply function row)) - (database-dump-result-set result-set database))))) - -(defun map-query-to-list (function query-expression database types) - (multiple-value-bind (result-set columns) - (database-query-result-set query-expression database :full-set nil - :types types) - (when result-set - (unwind-protect - (let ((result (list nil))) - (do ((row (make-list columns)) - (current-cons result (cdr current-cons))) - ((not (database-store-next-row result-set database row)) - (cdr result)) - (rplacd current-cons (list (apply function row))))) - (database-dump-result-set result-set database))))) - - -(defun map-query-to-simple (output-type-spec function query-expression database types) - (multiple-value-bind (result-set columns rows) - (database-query-result-set query-expression database :full-set t - :types types) - (when result-set - (unwind-protect - (if rows - ;; We know the row count in advance, so we allocate once - (do ((result - (cmucl-compat:make-sequence-of-type output-type-spec rows)) - (row (make-list columns)) - (index 0 (1+ index))) - ((not (database-store-next-row result-set database row)) - result) - (declare (fixnum index)) - (setf (aref result index) - (apply function row))) - ;; Database can't report row count in advance, so we have - ;; to grow and shrink our vector dynamically - (do ((result - (cmucl-compat:make-sequence-of-type output-type-spec 100)) - (allocated-length 100) - (row (make-list columns)) - (index 0 (1+ index))) - ((not (database-store-next-row result-set database row)) - (cmucl-compat:shrink-vector result index)) - (declare (fixnum allocated-length index)) - (when (>= index allocated-length) - (setq allocated-length (* allocated-length 2) - result (adjust-array result allocated-length))) - (setf (aref result index) - (apply function row)))) - (database-dump-result-set result-set database))))) - -(defmacro do-query (((&rest args) query-expression - &key (database '*default-database*) - (types nil)) - &body body) - (let ((result-set (gensym)) - (columns (gensym)) - (row (gensym)) - (db (gensym))) - `(let ((,db ,database)) - (multiple-value-bind (,result-set ,columns) - (database-query-result-set ,query-expression ,db - :full-set nil :types ,types) - (when ,result-set - (unwind-protect - (do ((,row (make-list ,columns))) - ((not (database-store-next-row ,result-set ,db ,row)) - nil) - (destructuring-bind ,args ,row - ,@body)) - (database-dump-result-set ,result-set ,db))))))) - -;;; Marc Battyani : Large objects support - -(defun create-large-object (&key (database *default-database*)) - "Creates a new large object in the database and returns the object identifier" - (database-create-large-object database)) - -(defun write-large-object (object-id data &key (database *default-database*)) - "Writes data to the large object" - (database-write-large-object object-id data database)) - -(defun read-large-object (object-id &key (database *default-database*)) - "Reads the large object content" - (database-read-large-object object-id database)) - -(defun delete-large-object (object-id &key (database *default-database*)) - "Deletes the large object in the database" - (database-delete-large-object object-id database)) diff --git a/sql/sql.lisp b/sql/sql.lisp new file mode 100644 index 0000000..12535e5 --- /dev/null +++ b/sql/sql.lisp @@ -0,0 +1,262 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: sql.cl +;;;; Purpose: High-level SQL interface +;;;; Programmers: Kevin M. Rosenberg based on +;;;; Original code by Pierre R. Mai +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: sql.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; and Copyright (c) 1999-2001 by Pierre R. Mai +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :clsql-sys) + +;;; Modified by KMR +;;; - to use CMUCL-COMPAT library +;;; - fix format strings in error messages +;;; - use field types + + +;;; Simple implementation of SQL along the lines of Harlequin's Common SQL + + +;;; Database handling + +(defvar *connect-if-exists* :error + "Default value for the if-exists parameter of connect calls.") + +(defvar *connected-databases* nil + "List of active database objects.") + +(defun connected-databases () + "Return the list of active database objects." + *connected-databases*) + +(defvar *default-database* nil + "Specifies the default database to be used.") + +(defun find-database (database &optional (errorp t)) + (etypecase database + (database + ;; Return the database object itself + database) + (string + (or (find database (connected-databases) + :key #'database-name + :test #'string=) + (when errorp + (cerror "Return nil." + 'clsql-simple-error + :format-control "There exists no database called ~A." + :format-arguments (list database))))))) + +(defun connect (connection-spec + &key (if-exists *connect-if-exists*) + (database-type *default-database-type*) + (pool nil)) + "Connects to a database of the given database-type, using the type-specific +connection-spec. if-exists is currently ignored. +If pool is t the the connection will be taken from the general pool, +if pool is a conn-pool object the connection will be taken from this pool. +" + (if pool + (acquire-from-pool connection-spec database-type pool) + (let* ((db-name (database-name-from-spec connection-spec database-type)) + (old-db (unless (eq if-exists :new) (find-database db-name nil))) + (result nil)) + (if old-db + (case if-exists +; (:new +; (setq result +; (database-connect connection-spec database-type))) + (:warn-new + (setq result + (database-connect connection-spec database-type)) + (warn 'clsql-exists-warning :old-db old-db :new-db result)) + (:error + (restart-case + (error 'clsql-exists-error :old-db old-db) + (create-new () + :report "Create a new connection." + (setq result + (database-connect connection-spec database-type))) + (use-old () + :report "Use the existing connection." + (setq result old-db)))) + (:warn-old + (setq result old-db) + (warn 'clsql-exists-warning :old-db old-db :new-db old-db)) + (:old + (setq result old-db))) + (setq result + (database-connect connection-spec database-type))) + (when result + (pushnew result *connected-databases*) + (setq *default-database* result) + result)))) + + +(defun disconnect (&key (database *default-database*)) + "Closes the connection to database. Resets *default-database* if that +database was disconnected and only one other connection exists. +if the database is from a pool it will be released to this pool." + (if (conn-pool database) + (release-to-pool database) + (when (database-disconnect database) + (setq *connected-databases* (delete database *connected-databases*)) + (when (eq database *default-database*) + (setq *default-database* (car *connected-databases*))) + (change-class database 'closed-database) + t))) + +;;; Basic operations on databases + +(defmethod query (query-expression &key (database *default-database*) + types) + "Execute the SQL query expression query-expression on the given database. +Returns a list of lists of values of the result of that expression." + (database-query query-expression database types)) + + + +(defmethod execute-command (sql-expression &key (database *default-database*)) + "Execute the SQL command expression sql-expression on the given database. +Returns true on success or nil on failure." + (database-execute-command sql-expression database)) + + + +(defun map-query (output-type-spec function query-expression + &key (database *default-database*) + (types nil)) + "Map the function over all tuples that are returned by the query in +query-expression. The results of the function are collected as +specified in output-type-spec and returned like in MAP." + ;; DANGER Will Robinson: Parts of the code for implementing + ;; map-query (including the code below and the helper functions + ;; called) are highly CMU CL specific. + ;; KMR -- these have been replaced with cross-platform instructions above + (macrolet ((type-specifier-atom (type) + `(if (atom ,type) ,type (car ,type)))) + (case (type-specifier-atom output-type-spec) + ((nil) + (map-query-for-effect function query-expression database types)) + (list + (map-query-to-list function query-expression database types)) + ((simple-vector simple-string vector string array simple-array + bit-vector simple-bit-vector base-string + simple-base-string) + (map-query-to-simple output-type-spec function query-expression database types)) + (t + (funcall #'map-query (cmucl-compat:result-type-or-lose output-type-spec t) + function query-expression :database database :types types))))) + +(defun map-query-for-effect (function query-expression database types) + (multiple-value-bind (result-set columns) + (database-query-result-set query-expression database :full-set nil + :types types) + (when result-set + (unwind-protect + (do ((row (make-list columns))) + ((not (database-store-next-row result-set database row)) + nil) + (apply function row)) + (database-dump-result-set result-set database))))) + +(defun map-query-to-list (function query-expression database types) + (multiple-value-bind (result-set columns) + (database-query-result-set query-expression database :full-set nil + :types types) + (when result-set + (unwind-protect + (let ((result (list nil))) + (do ((row (make-list columns)) + (current-cons result (cdr current-cons))) + ((not (database-store-next-row result-set database row)) + (cdr result)) + (rplacd current-cons (list (apply function row))))) + (database-dump-result-set result-set database))))) + + +(defun map-query-to-simple (output-type-spec function query-expression database types) + (multiple-value-bind (result-set columns rows) + (database-query-result-set query-expression database :full-set t + :types types) + (when result-set + (unwind-protect + (if rows + ;; We know the row count in advance, so we allocate once + (do ((result + (cmucl-compat:make-sequence-of-type output-type-spec rows)) + (row (make-list columns)) + (index 0 (1+ index))) + ((not (database-store-next-row result-set database row)) + result) + (declare (fixnum index)) + (setf (aref result index) + (apply function row))) + ;; Database can't report row count in advance, so we have + ;; to grow and shrink our vector dynamically + (do ((result + (cmucl-compat:make-sequence-of-type output-type-spec 100)) + (allocated-length 100) + (row (make-list columns)) + (index 0 (1+ index))) + ((not (database-store-next-row result-set database row)) + (cmucl-compat:shrink-vector result index)) + (declare (fixnum allocated-length index)) + (when (>= index allocated-length) + (setq allocated-length (* allocated-length 2) + result (adjust-array result allocated-length))) + (setf (aref result index) + (apply function row)))) + (database-dump-result-set result-set database))))) + +(defmacro do-query (((&rest args) query-expression + &key (database '*default-database*) + (types nil)) + &body body) + (let ((result-set (gensym)) + (columns (gensym)) + (row (gensym)) + (db (gensym))) + `(let ((,db ,database)) + (multiple-value-bind (,result-set ,columns) + (database-query-result-set ,query-expression ,db + :full-set nil :types ,types) + (when ,result-set + (unwind-protect + (do ((,row (make-list ,columns))) + ((not (database-store-next-row ,result-set ,db ,row)) + nil) + (destructuring-bind ,args ,row + ,@body)) + (database-dump-result-set ,result-set ,db))))))) + +;;; Marc Battyani : Large objects support + +(defun create-large-object (&key (database *default-database*)) + "Creates a new large object in the database and returns the object identifier" + (database-create-large-object database)) + +(defun write-large-object (object-id data &key (database *default-database*)) + "Writes data to the large object" + (database-write-large-object object-id data database)) + +(defun read-large-object (object-id &key (database *default-database*)) + "Reads the large object content" + (database-read-large-object object-id database)) + +(defun delete-large-object (object-id &key (database *default-database*)) + "Deletes the large object in the database" + (database-delete-large-object object-id database)) diff --git a/sql/transactions.cl b/sql/transactions.cl deleted file mode 100644 index c95e8c3..0000000 --- a/sql/transactions.cl +++ /dev/null @@ -1,85 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: transactions.cl -;;;; Purpose: Transaction support -;;;; Programmers: Marc Battyani -;;;; Date Started: Apr 2002 -;;;; -;;;; $Id: transactions.cl,v 1.7 2002/09/17 17:16:43 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-sys) - -;; I removed the USQL transaction stuff to put a smaller, lighter one (MB) - -(defclass transaction () - ((commit-hooks :initform () :accessor commit-hooks) - (rollback-hooks :initform () :accessor rollback-hooks) - (status :initform nil :accessor status))) ;can be nil :rolled-back or :commited - -(defmethod database-start-transaction ((database closed-database)) - (error 'clsql-closed-database-error database)) - -(defmethod database-start-transaction (database) - (unless (transaction database) - (setf (transaction database) (make-instance 'transaction))) - (when (= (incf (transaction-level database)) 1) - (let ((transaction (transaction database))) - (setf (commit-hooks transaction) nil - (rollback-hooks transaction) nil - (status transaction) nil) - (execute-command "BEGIN" :database database)))) - -(defmethod database-end-transaction ((database closed-database)) - (error 'clsql-closed-database-error database)) - -(defmethod database-end-transaction (database) - (if (> (transaction-level database) 0) - (when (zerop (decf (transaction-level database))) - (let ((transaction (transaction database))) - (if (eq (status transaction) :commited) - (progn - (execute-command "COMMIT" :database database) - (map nil #'funcall (commit-hooks transaction))) - (unwind-protect ;status is not :commited - (execute-command "ROLLBACK" :database database) - (map nil #'funcall (rollback-hooks transaction)))))) - (warn "Continue without commit." - 'clsql-simple-error - :format-control "Cannot commit transaction against ~A because there is no transaction in progress." - :format-arguments (list database)))) - -(defun rollback-transaction (database) - (when (and (transaction database)(not (status (transaction database)))) - (setf (status (transaction database)) :rolled-back))) - -(defun commit-transaction (database) - (when (and (transaction database)(not (status (transaction database)))) - (setf (status (transaction database)) :commited))) - -(defun add-transaction-commit-hook (database commit-hook) - (when (transaction database) - (push commit-hook (commit-hooks (transaction database))))) - -(defun add-transaction-rollback-hook (database rollback-hook) - (when (transaction database) - (push rollback-hook (rollback-hooks (transaction database))))) - -(defmacro with-transaction ((&key (database '*default-database*)) &rest body) - (let ((db (gensym "db-"))) - `(let ((,db ,database)) - (unwind-protect - (progn - (database-start-transaction ,db) - ,@body - (commit-transaction ,db)) - (database-end-transaction ,db))))) diff --git a/sql/transactions.lisp b/sql/transactions.lisp new file mode 100644 index 0000000..d0a4bb7 --- /dev/null +++ b/sql/transactions.lisp @@ -0,0 +1,85 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: transactions.cl +;;;; Purpose: Transaction support +;;;; Programmers: Marc Battyani +;;;; Date Started: Apr 2002 +;;;; +;;;; $Id: transactions.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :clsql-sys) + +;; I removed the USQL transaction stuff to put a smaller, lighter one (MB) + +(defclass transaction () + ((commit-hooks :initform () :accessor commit-hooks) + (rollback-hooks :initform () :accessor rollback-hooks) + (status :initform nil :accessor status))) ;can be nil :rolled-back or :commited + +(defmethod database-start-transaction ((database closed-database)) + (error 'clsql-closed-database-error database)) + +(defmethod database-start-transaction (database) + (unless (transaction database) + (setf (transaction database) (make-instance 'transaction))) + (when (= (incf (transaction-level database)) 1) + (let ((transaction (transaction database))) + (setf (commit-hooks transaction) nil + (rollback-hooks transaction) nil + (status transaction) nil) + (execute-command "BEGIN" :database database)))) + +(defmethod database-end-transaction ((database closed-database)) + (error 'clsql-closed-database-error database)) + +(defmethod database-end-transaction (database) + (if (> (transaction-level database) 0) + (when (zerop (decf (transaction-level database))) + (let ((transaction (transaction database))) + (if (eq (status transaction) :commited) + (progn + (execute-command "COMMIT" :database database) + (map nil #'funcall (commit-hooks transaction))) + (unwind-protect ;status is not :commited + (execute-command "ROLLBACK" :database database) + (map nil #'funcall (rollback-hooks transaction)))))) + (warn "Continue without commit." + 'clsql-simple-error + :format-control "Cannot commit transaction against ~A because there is no transaction in progress." + :format-arguments (list database)))) + +(defun rollback-transaction (database) + (when (and (transaction database)(not (status (transaction database)))) + (setf (status (transaction database)) :rolled-back))) + +(defun commit-transaction (database) + (when (and (transaction database)(not (status (transaction database)))) + (setf (status (transaction database)) :commited))) + +(defun add-transaction-commit-hook (database commit-hook) + (when (transaction database) + (push commit-hook (commit-hooks (transaction database))))) + +(defun add-transaction-rollback-hook (database rollback-hook) + (when (transaction database) + (push rollback-hook (rollback-hooks (transaction database))))) + +(defmacro with-transaction ((&key (database '*default-database*)) &rest body) + (let ((db (gensym "db-"))) + `(let ((,db ,database)) + (unwind-protect + (progn + (database-start-transaction ,db) + ,@body + (commit-transaction ,db)) + (database-end-transaction ,db))))) diff --git a/sql/usql.cl b/sql/usql.cl deleted file mode 100644 index 1141dc0..0000000 --- a/sql/usql.cl +++ /dev/null @@ -1,57 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: usql.cl -;;;; Purpose: High-level interface to SQL driver routines needed for -;;;; UncommonSQL -;;;; Programmers: Kevin M. Rosenberg and onShore Development Inc -;;;; Date Started: Mar 2002 -;;;; -;;;; $Id: usql.cl,v 1.11 2002/09/17 17:16:43 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; and onShore Development Inc -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - - -;;; Minimal high-level routines to enable low-level interface for USQL - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-sys) - -(defun list-tables (&key (database *default-database*) - (system-tables nil)) - "List all tables in *default-database*, or if the :database keyword arg -is given, the specified database. If the keyword arg :system-tables -is true, then it will not filter out non-user tables. Table names are -given back as a list of strings." - (database-list-tables database :system-tables system-tables)) - - -(defun list-attributes (table &key (database *default-database*)) - "List the attributes of TABLE in *default-database, or if the -:database keyword is given, the specified database. Attributes are -returned as a list of strings." - (database-list-attributes table database)) - -(defun attribute-type (attribute table &key (database *default-database*)) - "Return the field type of the ATTRIBUTE in TABLE. The optional -keyword argument :database specifies the database to query, defaulting -to *default-database*." - (database-attribute-type attribute table database)) - -(defun create-sequence (name &key (database *default-database*)) - (database-create-sequence name database)) - -(defun drop-sequence (name &key (database *default-database*)) - (database-drop-sequence name database)) - -(defun sequence-next (name &key (database *default-database*)) - (database-sequence-next name database)) - - diff --git a/sql/usql.lisp b/sql/usql.lisp new file mode 100644 index 0000000..984dce0 --- /dev/null +++ b/sql/usql.lisp @@ -0,0 +1,57 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: usql.cl +;;;; Purpose: High-level interface to SQL driver routines needed for +;;;; UncommonSQL +;;;; Programmers: Kevin M. Rosenberg and onShore Development Inc +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id: usql.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; and onShore Development Inc +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + + +;;; Minimal high-level routines to enable low-level interface for USQL + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :clsql-sys) + +(defun list-tables (&key (database *default-database*) + (system-tables nil)) + "List all tables in *default-database*, or if the :database keyword arg +is given, the specified database. If the keyword arg :system-tables +is true, then it will not filter out non-user tables. Table names are +given back as a list of strings." + (database-list-tables database :system-tables system-tables)) + + +(defun list-attributes (table &key (database *default-database*)) + "List the attributes of TABLE in *default-database, or if the +:database keyword is given, the specified database. Attributes are +returned as a list of strings." + (database-list-attributes table database)) + +(defun attribute-type (attribute table &key (database *default-database*)) + "Return the field type of the ATTRIBUTE in TABLE. The optional +keyword argument :database specifies the database to query, defaulting +to *default-database*." + (database-attribute-type attribute table database)) + +(defun create-sequence (name &key (database *default-database*)) + (database-create-sequence name database)) + +(defun drop-sequence (name &key (database *default-database*)) + (database-drop-sequence name database)) + +(defun sequence-next (name &key (database *default-database*)) + (database-sequence-next name database)) + + diff --git a/test-suite/acl-compat-tester.cl b/test-suite/acl-compat-tester.cl deleted file mode 100644 index 14b6bc9..0000000 --- a/test-suite/acl-compat-tester.cl +++ /dev/null @@ -1,600 +0,0 @@ -;; tester.cl -;; A test harness for Allegro CL. -;; -;; copyright (c) 1985-1986 Franz Inc, Alameda, CA -;; copyright (c) 1986-2001 Franz Inc, Berkeley, CA - All rights reserved. -;; -;; This code is free software; you can redistribute it and/or -;; modify it under the terms of the version 2.1 of -;; the GNU Lesser General Public License as published by -;; the Free Software Foundation, as clarified by the Franz -;; preamble to the LGPL found in -;; http://opensource.franz.com/preamble.html. -;; -;; This code 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 -;; Lesser General Public License for more details. -;; -;; Version 2.1 of the GNU Lesser General Public License can be -;; found at http://opensource.franz.com/license.html. -;; If it is not present, you can access it from -;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer -;; version) or write to the Free Software Foundation, Inc., 59 Temple -;; Place, Suite 330, Boston, MA 02111-1307 USA -;; -;;;; from the original ACL 6.1 sources: -;; $Id: acl-compat-tester.cl,v 1.3 2002/04/20 22:55:02 kevin Exp $ - - -(defpackage :util.test - (:use :common-lisp) - (:shadow #:test) - (:export -;;;; Control variables: - #:*break-on-test-failures* - #:*error-protect-tests* - #:*test-errors* - #:*test-successes* - #:*test-unexpected-failures* - -;;;; The test macros: - #:test - #:test-error - #:test-no-error - #:test-warning - #:test-no-warning - - #:with-tests - )) - -(in-package :util.test) - -#+cmu -(unless (find-class 'break nil) - (define-condition break (simple-condition) ())) - -(define-condition simple-break (error simple-condition) ()) - -;; the if* macro used in Allegro: -;; -;; This is in the public domain... please feel free to put this definition -;; in your code or distribute it with your version of lisp. - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defvar if*-keyword-list '("then" "thenret" "else" "elseif"))) - -(defmacro if* (&rest args) - (do ((xx (reverse args) (cdr xx)) - (state :init) - (elseseen nil) - (totalcol nil) - (lookat nil nil) - (col nil)) - ((null xx) - (cond ((eq state :compl) - `(cond ,@totalcol)) - (t (error "if*: illegal form ~s" args)))) - (cond ((and (symbolp (car xx)) - (member (symbol-name (car xx)) - if*-keyword-list - :test #'string-equal)) - (setq lookat (symbol-name (car xx))))) - - (cond ((eq state :init) - (cond (lookat (cond ((string-equal lookat "thenret") - (setq col nil - state :then)) - (t (error - "if*: bad keyword ~a" lookat)))) - (t (setq state :col - col nil) - (push (car xx) col)))) - ((eq state :col) - (cond (lookat - (cond ((string-equal lookat "else") - (cond (elseseen - (error - "if*: multiples elses"))) - (setq elseseen t) - (setq state :init) - (push `(t ,@col) totalcol)) - ((string-equal lookat "then") - (setq state :then)) - (t (error "if*: bad keyword ~s" - lookat)))) - (t (push (car xx) col)))) - ((eq state :then) - (cond (lookat - (error - "if*: keyword ~s at the wrong place " (car xx))) - (t (setq state :compl) - (push `(,(car xx) ,@col) totalcol)))) - ((eq state :compl) - (cond ((not (string-equal lookat "elseif")) - (error "if*: missing elseif clause "))) - (setq state :init))))) - - - - -(defvar *break-on-test-failures* nil - "When a test failure occurs, common-lisp:break is called, allowing -interactive debugging of the failure.") - -(defvar *test-errors* 0 - "The value is the number of test errors which have occurred.") -(defvar *test-successes* 0 - "The value is the number of test successes which have occurred.") -(defvar *test-unexpected-failures* 0 - "The value is the number of unexpected test failures which have occurred.") - -(defvar *error-protect-tests* nil - "Protect each test from errors. If an error occurs, then that will be -taken as a test failure unless test-error is being used.") - -(defmacro test-values-errorset (form &optional announce catch-breaks) - ;; internal macro - (let ((g-announce (gensym)) - (g-catch-breaks (gensym))) - `(let* ((,g-announce ,announce) - (,g-catch-breaks ,catch-breaks)) - (handler-case (cons t (multiple-value-list ,form)) - (condition (condition) - (if* (and (null ,g-catch-breaks) - (typep condition 'simple-break)) - then (break condition) - elseif ,g-announce - then (format *error-output* "~&Condition type: ~a~%" - (class-of condition)) - (format *error-output* "~&Message: ~a~%" condition)) - condition))))) - -(defmacro test-values (form &optional announce catch-breaks) - ;; internal macro - (if* *error-protect-tests* - then `(test-values-errorset ,form ,announce ,catch-breaks) - else `(cons t (multiple-value-list ,form)))) - -(defmacro test (expected-value test-form - &key (test #'eql test-given) - (multiple-values nil multiple-values-given) - (fail-info nil fail-info-given) - (known-failure nil known-failure-given) - -;;;;;;;;;; internal, undocumented keywords: -;;;; Note about these keywords: if they were documented, we'd have a -;;;; problem, since they break the left-to-right order of evaluation. -;;;; Specifically, errorset breaks it, and I don't see any way around -;;;; that. `errorset' is used by the old test.cl module (eg, -;;;; test-equal-errorset). - errorset - reported-form - (wanted-message nil wanted-message-given) - (got-message nil got-message-given)) - "Perform a single test. `expected-value' is the reference value for the -test. `test-form' is a form that will produce the value to be compared to -the expected-value. If the values are not the same, then an error is -logged, otherwise a success is logged. - -Normally the comparison of values is done with `eql'. The `test' keyword -argument can be used to specify other comparison functions, such as eq, -equal,equalp, string=, string-equal, etc. - -Normally, only the first return value from the test-form is considered, -however if `multiple-values' is t, then all values returned from test-form -are considered. - -`fail-info' allows more information to be printed with a test failure. - -`known-failure' marks the test as a known failure. This allows for -programs that do regression analysis on the output from a test run to -discriminate on new versus known failures." - `(test-check - :expected-result ,expected-value - :test-results - (,(if errorset 'test-values-errorset 'test-values) ,test-form t) - ,@(when test-given `(:predicate ,test)) - ,@(when multiple-values-given `(:multiple-values ,multiple-values)) - ,@(when fail-info-given `(:fail-info ,fail-info)) - ,@(when known-failure-given `(:known-failure ,known-failure)) - :test-form ',(if reported-form reported-form test-form) - ,@(when wanted-message-given `(:wanted-message ,wanted-message)) - ,@(when got-message-given `(:got-message ,got-message)))) - -(defmethod conditionp ((thing condition)) t) -(defmethod conditionp ((thing t)) nil) - -(defmacro test-error (form &key announce - catch-breaks - (fail-info nil fail-info-given) - (known-failure nil known-failure-given) - (condition-type ''simple-error) - (include-subtypes nil include-subtypes-given) - (format-control nil format-control-given) - (format-arguments nil format-arguments-given)) - "Test that `form' signals an error. The order of evaluation of the -arguments is keywords first, then test form. - -If `announce' is non-nil, then cause the error message to be printed. - -The `catch-breaks' is non-nil then consider a call to common-lisp:break an -`error'. - -`fail-info' allows more information to be printed with a test failure. - -`known-failure' marks the test as a known failure. This allows for -programs that do regression analysis on the output from a test run to -discriminate on new versus known failures. - -If `condition-type' is non-nil, it should be a symbol naming a condition -type, which is used to check against the signalled condition type. The -test will fail if they do not match. - -`include-subtypes', used with `condition-type', can be used to match a -condition to an entire subclass of the condition type hierarchy. - -`format-control' and `format-arguments' can be used to check the error -message itself." - (let ((g-announce (gensym)) - (g-catch-breaks (gensym)) - (g-fail-info (gensym)) - (g-known-failure (gensym)) - (g-condition-type (gensym)) - (g-include-subtypes (gensym)) - (g-format-control (gensym)) - (g-format-arguments (gensym)) - (g-c (gensym))) - `(let* ((,g-announce ,announce) - (,g-catch-breaks ,catch-breaks) - ,@(when fail-info-given `((,g-fail-info ,fail-info))) - ,@(when known-failure-given `((,g-known-failure ,known-failure))) - (,g-condition-type ,condition-type) - ,@(when include-subtypes-given - `((,g-include-subtypes ,include-subtypes))) - ,@(when format-control-given - `((,g-format-control ,format-control))) - ,@(when format-arguments-given - `((,g-format-arguments ,format-arguments))) - (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks))) - (test-check - :predicate #'eq - :expected-result t - :test-results - (test-values (and (conditionp ,g-c) - ,@(if* include-subtypes-given - then `((if* ,g-include-subtypes - then (typep ,g-c ,g-condition-type) - else (eq (class-of ,g-c) - (find-class - ,g-condition-type)))) - else `((eq (class-of ,g-c) - (find-class ,g-condition-type)))) - ,@(when format-control-given - `((or - (null ,g-format-control) - (string= - (concatenate 'simple-string - "~1@<" ,g-format-control "~:@>") - (simple-condition-format-control ,g-c))))) - ,@(when format-arguments-given - `((or - (null ,g-format-arguments) - (equal - ,g-format-arguments - (simple-condition-format-arguments ,g-c)))))) - t) - :test-form ',form - ,@(when fail-info-given `(:fail-info ,g-fail-info)) - ,@(when known-failure-given `(:known-failure ,g-known-failure)) - :condition-type ,g-condition-type - :condition ,g-c - ,@(when include-subtypes-given - `(:include-subtypes ,g-include-subtypes)) - ,@(when format-control-given - `(:format-control ,g-format-control)) - ,@(when format-arguments-given - `(:format-arguments ,g-format-arguments)))))) - -(defmacro test-no-error (form &key announce - catch-breaks - (fail-info nil fail-info-given) - (known-failure nil known-failure-given)) - "Test that `form' does not signal an error. The order of evaluation of -the arguments is keywords first, then test form. - -If `announce' is non-nil, then cause the error message to be printed. - -The `catch-breaks' is non-nil then consider a call to common-lisp:break an -`error'. - -`fail-info' allows more information to be printed with a test failure. - -`known-failure' marks the test as a known failure. This allows for -programs that do regression analysis on the output from a test run to -discriminate on new versus known failures." - (let ((g-announce (gensym)) - (g-catch-breaks (gensym)) - (g-fail-info (gensym)) - (g-known-failure (gensym)) - (g-c (gensym))) - `(let* ((,g-announce ,announce) - (,g-catch-breaks ,catch-breaks) - ,@(when fail-info-given `((,g-fail-info ,fail-info))) - ,@(when known-failure-given `((,g-known-failure ,known-failure))) - (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks))) - (test-check - :predicate #'eq - :expected-result t - :test-results (test-values (not (conditionp ,g-c))) - :test-form ',form - :condition ,g-c - ,@(when fail-info-given `(:fail-info ,g-fail-info)) - ,@(when known-failure-given `(:known-failure ,g-known-failure)))))) - -(defvar *warn-cookie* (cons nil nil)) - -(defmacro test-warning (form &key fail-info known-failure) - "Test that `form' signals a warning. The order of evaluation of -the arguments is keywords first, then test form. - -`fail-info' allows more information to be printed with a test failure. - -`known-failure' marks the test as a known failure. This allows for -programs that do regression analysis on the output from a test run to -discriminate on new versus known failures." - (let ((g-fail-info (gensym)) - (g-known-failure (gensym)) - (g-value (gensym))) - `(let* ((,g-fail-info ,fail-info) - (,g-known-failure ,known-failure) - (,g-value (test-values-errorset ,form nil t))) - (test - *warn-cookie* - (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning)) - then *warn-cookie* - else ;; test produced no warning - nil) - :test #'eq - :reported-form ,form ;; quoted by test macro - :wanted-message "a warning" - :got-message "no warning" - :fail-info ,g-fail-info - :known-failure ,g-known-failure)))) - -(defmacro test-no-warning (form &key fail-info known-failure) - "Test that `form' does not signal a warning. The order of evaluation of -the arguments is keywords first, then test form. - -`fail-info' allows more information to be printed with a test failure. - -`known-failure' marks the test as a known failure. This allows for -programs that do regression analysis on the output from a test run to -discriminate on new versus known failures." - (let ((g-fail-info (gensym)) - (g-known-failure (gensym)) - (g-value (gensym))) - `(let* ((,g-fail-info ,fail-info) - (,g-known-failure ,known-failure) - (,g-value (test-values-errorset ,form nil t))) - (test - *warn-cookie* - (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning)) - then nil ;; test produced warning - else *warn-cookie*) - :test #'eq - :reported-form ',form - :wanted-message "no warning" - :got-message "a warning" - :fail-info ,g-fail-info - :known-failure ,g-known-failure)))) - -(defvar *announce-test* nil) ;; if true announce each test that was done - -(defmacro errorset (form &optional announce catch-breaks) - ;; Evaluate FORM, and if there are no errors and FORM returns - ;; values v1,v2,...,vn, then return values t,v1,v2,...,vn. If an - ;; error occurs while evaluating FORM, then return nil immediately. - ;; If ANNOUNCE is t, then the error message will be printed out. - (if catch-breaks - `(handler-case (values-list (cons t (multiple-value-list ,form))) - (error (condition) - (declare (ignore-if-unused condition)) - ,@(if announce `((format *error-output* "~&Error: ~a~%" condition))) - nil) - (simple-break (condition) - (declare (ignore-if-unused condition)) - ,@(if announce `((format *error-output* "~&Warning: ~a~%" condition)) -) - nil)) - `(handler-case (values-list (cons t (multiple-value-list ,form))) - (error (condition) - (declare (ignore-if-unused condition)) - ,@(if announce `((format *error-output* "~&Error: ~a~%" condition))) - nil)))) - -(defun test-check (&key (predicate #'eql) - expected-result test-results test-form - multiple-values fail-info known-failure - wanted-message got-message condition-type condition - include-subtypes format-control format-arguments - &aux fail predicate-failed got wanted) - ;; for debugging large/complex test sets: - (when *announce-test* - (format t "Just did test ~s~%" test-form) - (force-output)) - - ;; this is an internal function - (flet ((check (expected-result result) - (let* ((results - (multiple-value-list - (errorset (funcall predicate expected-result result) t))) - (failed (null (car results)))) - (if* failed - then (setq predicate-failed t) - nil - else (cadr results))))) - (when (conditionp test-results) - (setq condition test-results) - (setq test-results nil)) - (when (null (car test-results)) - (setq fail t)) - (if* (and (not fail) (not multiple-values)) - then ;; should be a single result - ;; expected-result is the single result wanted - (when (not (and (cdr test-results) - (check expected-result (cadr test-results)))) - (setq fail t)) - (when (and (not fail) (cddr test-results)) - (setq fail 'single-got-multiple)) - else ;; multiple results wanted - ;; expected-result is a list of results, each of which - ;; should be checked against the corresponding test-results - ;; using the predicate - (do ((got (cdr test-results) (cdr got)) - (want expected-result (cdr want))) - ((or (null got) (null want)) - (when (not (and (null want) (null got))) - (setq fail t))) - (when (not (check (car got) (car want))) - (return (setq fail t))))) - (if* fail - then (when (not known-failure) - (format *error-output* - "~& * * * UNEXPECTED TEST FAILURE * * *~%") - (incf *test-unexpected-failures*)) - (format *error-output* "~&Test failed: ~@[known failure: ~*~]~s~%" - known-failure test-form) - (if* (eq 'single-got-multiple fail) - then (format - *error-output* - "~ -Reason: additional value were returned from test form.~%") - elseif predicate-failed - then (format *error-output* "Reason: predicate error.~%") - elseif (null (car test-results)) - then (format *error-output* "~ -Reason: an error~@[ (of type `~s')~] was detected.~%" - (when condition (class-of condition))) - elseif condition - then (if* (not (conditionp condition)) - then (format *error-output* "~ -Reason: expected but did not detect an error of type `~s'.~%" - condition-type) - elseif (null condition-type) - then (format *error-output* "~ -Reason: detected an unexpected error of type `~s': - ~a.~%" - (class-of condition) - condition) - elseif (not (if* include-subtypes - then (typep condition condition-type) - else (eq (class-of condition) - (find-class condition-type)))) - then (format *error-output* "~ -Reason: detected an incorrect condition type.~%") - (format *error-output* - " wanted: ~s~%" condition-type) - (format *error-output* - " got: ~s~%" (class-of condition)) - elseif (and format-control - (not (string= - (setq got - (concatenate 'simple-string - "~1@<" format-control "~:@>")) - (setq wanted - (simple-condition-format-control - condition))))) - then ;; format control doesn't match - (format *error-output* "~ -Reason: the format-control was incorrect.~%") - (format *error-output* " wanted: ~s~%" wanted) - (format *error-output* " got: ~s~%" got) - elseif (and format-arguments - (not (equal - (setq got format-arguments) - (setq wanted - (simple-condition-format-arguments - condition))))) - then (format *error-output* "~ -Reason: the format-arguments were incorrect.~%") - (format *error-output* " wanted: ~s~%" wanted) - (format *error-output* " got: ~s~%" got) - else ;; what else???? - (error "internal-error")) - else (let ((*print-length* 50) - (*print-level* 10)) - (if* wanted-message - then (format *error-output* - " wanted: ~a~%" wanted-message) - else (if* (not multiple-values) - then (format *error-output* - " wanted: ~s~%" - expected-result) - else (format - *error-output* - " wanted values: ~{~s~^, ~}~%" - expected-result))) - (if* got-message - then (format *error-output* - " got: ~a~%" got-message) - else (if* (not multiple-values) - then (format *error-output* " got: ~s~%" - (second test-results)) - else (format - *error-output* - " got values: ~{~s~^, ~}~%" - (cdr test-results)))))) - (when fail-info - (format *error-output* "Additional info: ~a~%" fail-info)) - (incf *test-errors*) - (when *break-on-test-failures* - (break "~a is non-nil." '*break-on-test-failures*)) - else (when known-failure - (format *error-output* - "~&Expected test failure for ~s did not occur.~%" - test-form) - (when fail-info - (format *error-output* "Additional info: ~a~%" fail-info)) - (setq fail t)) - (incf *test-successes*)) - (not fail))) - -(defmacro with-tests ((&key (name "unnamed")) &body body) - (let ((g-name (gensym))) - `(flet ((doit () ,@body)) - (let ((,g-name ,name) - (*test-errors* 0) - (*test-successes* 0) - (*test-unexpected-failures* 0)) - (format *error-output* "Begin ~a test~%" ,g-name) - (if* *break-on-test-failures* - then (doit) - else (handler-case (doit) - (error (c) - (format - *error-output* - "~ -~&Test ~a aborted by signalling an uncaught error:~%~a~%" - ,g-name c)))) - #+allegro - (let ((state (sys:gsgc-switch :print))) - (setf (sys:gsgc-switch :print) nil) - (format t "~&**********************************~%" ,g-name) - (format t "End ~a test~%" ,g-name) - (format t "Errors detected in this test: ~s " *test-errors*) - (unless (zerop *test-unexpected-failures*) - (format t "UNEXPECTED: ~s" *test-unexpected-failures*)) - (format t "~%Successes this test:~s~%" *test-successes*) - (setf (sys:gsgc-switch :print) state)) - #-allegro - (progn - (format t "~&**********************************~%" ,g-name) - (format t "End ~a test~%" ,g-name) - (format t "Errors detected in this test: ~s " *test-errors*) - (unless (zerop *test-unexpected-failures*) - (format t "UNEXPECTED: ~s" *test-unexpected-failures*)) - (format t "~%Successes this test:~s~%" *test-successes*)) - )))) - -(provide :tester #+module-versions 1.1) diff --git a/test-suite/acl-compat-tester.lisp b/test-suite/acl-compat-tester.lisp new file mode 100644 index 0000000..b775ea9 --- /dev/null +++ b/test-suite/acl-compat-tester.lisp @@ -0,0 +1,600 @@ +;; tester.cl +;; A test harness for Allegro CL. +;; +;; copyright (c) 1985-1986 Franz Inc, Alameda, CA +;; copyright (c) 1986-2001 Franz Inc, Berkeley, CA - All rights reserved. +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the Franz +;; preamble to the LGPL found in +;; http://opensource.franz.com/preamble.html. +;; +;; This code 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 +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License can be +;; found at http://opensource.franz.com/license.html. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple +;; Place, Suite 330, Boston, MA 02111-1307 USA +;; +;;;; from the original ACL 6.1 sources: +;; $Id: acl-compat-tester.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $ + + +(defpackage :util.test + (:use :common-lisp) + (:shadow #:test) + (:export +;;;; Control variables: + #:*break-on-test-failures* + #:*error-protect-tests* + #:*test-errors* + #:*test-successes* + #:*test-unexpected-failures* + +;;;; The test macros: + #:test + #:test-error + #:test-no-error + #:test-warning + #:test-no-warning + + #:with-tests + )) + +(in-package :util.test) + +#+cmu +(unless (find-class 'break nil) + (define-condition break (simple-condition) ())) + +(define-condition simple-break (error simple-condition) ()) + +;; the if* macro used in Allegro: +;; +;; This is in the public domain... please feel free to put this definition +;; in your code or distribute it with your version of lisp. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar if*-keyword-list '("then" "thenret" "else" "elseif"))) + +(defmacro if* (&rest args) + (do ((xx (reverse args) (cdr xx)) + (state :init) + (elseseen nil) + (totalcol nil) + (lookat nil nil) + (col nil)) + ((null xx) + (cond ((eq state :compl) + `(cond ,@totalcol)) + (t (error "if*: illegal form ~s" args)))) + (cond ((and (symbolp (car xx)) + (member (symbol-name (car xx)) + if*-keyword-list + :test #'string-equal)) + (setq lookat (symbol-name (car xx))))) + + (cond ((eq state :init) + (cond (lookat (cond ((string-equal lookat "thenret") + (setq col nil + state :then)) + (t (error + "if*: bad keyword ~a" lookat)))) + (t (setq state :col + col nil) + (push (car xx) col)))) + ((eq state :col) + (cond (lookat + (cond ((string-equal lookat "else") + (cond (elseseen + (error + "if*: multiples elses"))) + (setq elseseen t) + (setq state :init) + (push `(t ,@col) totalcol)) + ((string-equal lookat "then") + (setq state :then)) + (t (error "if*: bad keyword ~s" + lookat)))) + (t (push (car xx) col)))) + ((eq state :then) + (cond (lookat + (error + "if*: keyword ~s at the wrong place " (car xx))) + (t (setq state :compl) + (push `(,(car xx) ,@col) totalcol)))) + ((eq state :compl) + (cond ((not (string-equal lookat "elseif")) + (error "if*: missing elseif clause "))) + (setq state :init))))) + + + + +(defvar *break-on-test-failures* nil + "When a test failure occurs, common-lisp:break is called, allowing +interactive debugging of the failure.") + +(defvar *test-errors* 0 + "The value is the number of test errors which have occurred.") +(defvar *test-successes* 0 + "The value is the number of test successes which have occurred.") +(defvar *test-unexpected-failures* 0 + "The value is the number of unexpected test failures which have occurred.") + +(defvar *error-protect-tests* nil + "Protect each test from errors. If an error occurs, then that will be +taken as a test failure unless test-error is being used.") + +(defmacro test-values-errorset (form &optional announce catch-breaks) + ;; internal macro + (let ((g-announce (gensym)) + (g-catch-breaks (gensym))) + `(let* ((,g-announce ,announce) + (,g-catch-breaks ,catch-breaks)) + (handler-case (cons t (multiple-value-list ,form)) + (condition (condition) + (if* (and (null ,g-catch-breaks) + (typep condition 'simple-break)) + then (break condition) + elseif ,g-announce + then (format *error-output* "~&Condition type: ~a~%" + (class-of condition)) + (format *error-output* "~&Message: ~a~%" condition)) + condition))))) + +(defmacro test-values (form &optional announce catch-breaks) + ;; internal macro + (if* *error-protect-tests* + then `(test-values-errorset ,form ,announce ,catch-breaks) + else `(cons t (multiple-value-list ,form)))) + +(defmacro test (expected-value test-form + &key (test #'eql test-given) + (multiple-values nil multiple-values-given) + (fail-info nil fail-info-given) + (known-failure nil known-failure-given) + +;;;;;;;;;; internal, undocumented keywords: +;;;; Note about these keywords: if they were documented, we'd have a +;;;; problem, since they break the left-to-right order of evaluation. +;;;; Specifically, errorset breaks it, and I don't see any way around +;;;; that. `errorset' is used by the old test.cl module (eg, +;;;; test-equal-errorset). + errorset + reported-form + (wanted-message nil wanted-message-given) + (got-message nil got-message-given)) + "Perform a single test. `expected-value' is the reference value for the +test. `test-form' is a form that will produce the value to be compared to +the expected-value. If the values are not the same, then an error is +logged, otherwise a success is logged. + +Normally the comparison of values is done with `eql'. The `test' keyword +argument can be used to specify other comparison functions, such as eq, +equal,equalp, string=, string-equal, etc. + +Normally, only the first return value from the test-form is considered, +however if `multiple-values' is t, then all values returned from test-form +are considered. + +`fail-info' allows more information to be printed with a test failure. + +`known-failure' marks the test as a known failure. This allows for +programs that do regression analysis on the output from a test run to +discriminate on new versus known failures." + `(test-check + :expected-result ,expected-value + :test-results + (,(if errorset 'test-values-errorset 'test-values) ,test-form t) + ,@(when test-given `(:predicate ,test)) + ,@(when multiple-values-given `(:multiple-values ,multiple-values)) + ,@(when fail-info-given `(:fail-info ,fail-info)) + ,@(when known-failure-given `(:known-failure ,known-failure)) + :test-form ',(if reported-form reported-form test-form) + ,@(when wanted-message-given `(:wanted-message ,wanted-message)) + ,@(when got-message-given `(:got-message ,got-message)))) + +(defmethod conditionp ((thing condition)) t) +(defmethod conditionp ((thing t)) nil) + +(defmacro test-error (form &key announce + catch-breaks + (fail-info nil fail-info-given) + (known-failure nil known-failure-given) + (condition-type ''simple-error) + (include-subtypes nil include-subtypes-given) + (format-control nil format-control-given) + (format-arguments nil format-arguments-given)) + "Test that `form' signals an error. The order of evaluation of the +arguments is keywords first, then test form. + +If `announce' is non-nil, then cause the error message to be printed. + +The `catch-breaks' is non-nil then consider a call to common-lisp:break an +`error'. + +`fail-info' allows more information to be printed with a test failure. + +`known-failure' marks the test as a known failure. This allows for +programs that do regression analysis on the output from a test run to +discriminate on new versus known failures. + +If `condition-type' is non-nil, it should be a symbol naming a condition +type, which is used to check against the signalled condition type. The +test will fail if they do not match. + +`include-subtypes', used with `condition-type', can be used to match a +condition to an entire subclass of the condition type hierarchy. + +`format-control' and `format-arguments' can be used to check the error +message itself." + (let ((g-announce (gensym)) + (g-catch-breaks (gensym)) + (g-fail-info (gensym)) + (g-known-failure (gensym)) + (g-condition-type (gensym)) + (g-include-subtypes (gensym)) + (g-format-control (gensym)) + (g-format-arguments (gensym)) + (g-c (gensym))) + `(let* ((,g-announce ,announce) + (,g-catch-breaks ,catch-breaks) + ,@(when fail-info-given `((,g-fail-info ,fail-info))) + ,@(when known-failure-given `((,g-known-failure ,known-failure))) + (,g-condition-type ,condition-type) + ,@(when include-subtypes-given + `((,g-include-subtypes ,include-subtypes))) + ,@(when format-control-given + `((,g-format-control ,format-control))) + ,@(when format-arguments-given + `((,g-format-arguments ,format-arguments))) + (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks))) + (test-check + :predicate #'eq + :expected-result t + :test-results + (test-values (and (conditionp ,g-c) + ,@(if* include-subtypes-given + then `((if* ,g-include-subtypes + then (typep ,g-c ,g-condition-type) + else (eq (class-of ,g-c) + (find-class + ,g-condition-type)))) + else `((eq (class-of ,g-c) + (find-class ,g-condition-type)))) + ,@(when format-control-given + `((or + (null ,g-format-control) + (string= + (concatenate 'simple-string + "~1@<" ,g-format-control "~:@>") + (simple-condition-format-control ,g-c))))) + ,@(when format-arguments-given + `((or + (null ,g-format-arguments) + (equal + ,g-format-arguments + (simple-condition-format-arguments ,g-c)))))) + t) + :test-form ',form + ,@(when fail-info-given `(:fail-info ,g-fail-info)) + ,@(when known-failure-given `(:known-failure ,g-known-failure)) + :condition-type ,g-condition-type + :condition ,g-c + ,@(when include-subtypes-given + `(:include-subtypes ,g-include-subtypes)) + ,@(when format-control-given + `(:format-control ,g-format-control)) + ,@(when format-arguments-given + `(:format-arguments ,g-format-arguments)))))) + +(defmacro test-no-error (form &key announce + catch-breaks + (fail-info nil fail-info-given) + (known-failure nil known-failure-given)) + "Test that `form' does not signal an error. The order of evaluation of +the arguments is keywords first, then test form. + +If `announce' is non-nil, then cause the error message to be printed. + +The `catch-breaks' is non-nil then consider a call to common-lisp:break an +`error'. + +`fail-info' allows more information to be printed with a test failure. + +`known-failure' marks the test as a known failure. This allows for +programs that do regression analysis on the output from a test run to +discriminate on new versus known failures." + (let ((g-announce (gensym)) + (g-catch-breaks (gensym)) + (g-fail-info (gensym)) + (g-known-failure (gensym)) + (g-c (gensym))) + `(let* ((,g-announce ,announce) + (,g-catch-breaks ,catch-breaks) + ,@(when fail-info-given `((,g-fail-info ,fail-info))) + ,@(when known-failure-given `((,g-known-failure ,known-failure))) + (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks))) + (test-check + :predicate #'eq + :expected-result t + :test-results (test-values (not (conditionp ,g-c))) + :test-form ',form + :condition ,g-c + ,@(when fail-info-given `(:fail-info ,g-fail-info)) + ,@(when known-failure-given `(:known-failure ,g-known-failure)))))) + +(defvar *warn-cookie* (cons nil nil)) + +(defmacro test-warning (form &key fail-info known-failure) + "Test that `form' signals a warning. The order of evaluation of +the arguments is keywords first, then test form. + +`fail-info' allows more information to be printed with a test failure. + +`known-failure' marks the test as a known failure. This allows for +programs that do regression analysis on the output from a test run to +discriminate on new versus known failures." + (let ((g-fail-info (gensym)) + (g-known-failure (gensym)) + (g-value (gensym))) + `(let* ((,g-fail-info ,fail-info) + (,g-known-failure ,known-failure) + (,g-value (test-values-errorset ,form nil t))) + (test + *warn-cookie* + (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning)) + then *warn-cookie* + else ;; test produced no warning + nil) + :test #'eq + :reported-form ,form ;; quoted by test macro + :wanted-message "a warning" + :got-message "no warning" + :fail-info ,g-fail-info + :known-failure ,g-known-failure)))) + +(defmacro test-no-warning (form &key fail-info known-failure) + "Test that `form' does not signal a warning. The order of evaluation of +the arguments is keywords first, then test form. + +`fail-info' allows more information to be printed with a test failure. + +`known-failure' marks the test as a known failure. This allows for +programs that do regression analysis on the output from a test run to +discriminate on new versus known failures." + (let ((g-fail-info (gensym)) + (g-known-failure (gensym)) + (g-value (gensym))) + `(let* ((,g-fail-info ,fail-info) + (,g-known-failure ,known-failure) + (,g-value (test-values-errorset ,form nil t))) + (test + *warn-cookie* + (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning)) + then nil ;; test produced warning + else *warn-cookie*) + :test #'eq + :reported-form ',form + :wanted-message "no warning" + :got-message "a warning" + :fail-info ,g-fail-info + :known-failure ,g-known-failure)))) + +(defvar *announce-test* nil) ;; if true announce each test that was done + +(defmacro errorset (form &optional announce catch-breaks) + ;; Evaluate FORM, and if there are no errors and FORM returns + ;; values v1,v2,...,vn, then return values t,v1,v2,...,vn. If an + ;; error occurs while evaluating FORM, then return nil immediately. + ;; If ANNOUNCE is t, then the error message will be printed out. + (if catch-breaks + `(handler-case (values-list (cons t (multiple-value-list ,form))) + (error (condition) + (declare (ignore-if-unused condition)) + ,@(if announce `((format *error-output* "~&Error: ~a~%" condition))) + nil) + (simple-break (condition) + (declare (ignore-if-unused condition)) + ,@(if announce `((format *error-output* "~&Warning: ~a~%" condition)) +) + nil)) + `(handler-case (values-list (cons t (multiple-value-list ,form))) + (error (condition) + (declare (ignore-if-unused condition)) + ,@(if announce `((format *error-output* "~&Error: ~a~%" condition))) + nil)))) + +(defun test-check (&key (predicate #'eql) + expected-result test-results test-form + multiple-values fail-info known-failure + wanted-message got-message condition-type condition + include-subtypes format-control format-arguments + &aux fail predicate-failed got wanted) + ;; for debugging large/complex test sets: + (when *announce-test* + (format t "Just did test ~s~%" test-form) + (force-output)) + + ;; this is an internal function + (flet ((check (expected-result result) + (let* ((results + (multiple-value-list + (errorset (funcall predicate expected-result result) t))) + (failed (null (car results)))) + (if* failed + then (setq predicate-failed t) + nil + else (cadr results))))) + (when (conditionp test-results) + (setq condition test-results) + (setq test-results nil)) + (when (null (car test-results)) + (setq fail t)) + (if* (and (not fail) (not multiple-values)) + then ;; should be a single result + ;; expected-result is the single result wanted + (when (not (and (cdr test-results) + (check expected-result (cadr test-results)))) + (setq fail t)) + (when (and (not fail) (cddr test-results)) + (setq fail 'single-got-multiple)) + else ;; multiple results wanted + ;; expected-result is a list of results, each of which + ;; should be checked against the corresponding test-results + ;; using the predicate + (do ((got (cdr test-results) (cdr got)) + (want expected-result (cdr want))) + ((or (null got) (null want)) + (when (not (and (null want) (null got))) + (setq fail t))) + (when (not (check (car got) (car want))) + (return (setq fail t))))) + (if* fail + then (when (not known-failure) + (format *error-output* + "~& * * * UNEXPECTED TEST FAILURE * * *~%") + (incf *test-unexpected-failures*)) + (format *error-output* "~&Test failed: ~@[known failure: ~*~]~s~%" + known-failure test-form) + (if* (eq 'single-got-multiple fail) + then (format + *error-output* + "~ +Reason: additional value were returned from test form.~%") + elseif predicate-failed + then (format *error-output* "Reason: predicate error.~%") + elseif (null (car test-results)) + then (format *error-output* "~ +Reason: an error~@[ (of type `~s')~] was detected.~%" + (when condition (class-of condition))) + elseif condition + then (if* (not (conditionp condition)) + then (format *error-output* "~ +Reason: expected but did not detect an error of type `~s'.~%" + condition-type) + elseif (null condition-type) + then (format *error-output* "~ +Reason: detected an unexpected error of type `~s': + ~a.~%" + (class-of condition) + condition) + elseif (not (if* include-subtypes + then (typep condition condition-type) + else (eq (class-of condition) + (find-class condition-type)))) + then (format *error-output* "~ +Reason: detected an incorrect condition type.~%") + (format *error-output* + " wanted: ~s~%" condition-type) + (format *error-output* + " got: ~s~%" (class-of condition)) + elseif (and format-control + (not (string= + (setq got + (concatenate 'simple-string + "~1@<" format-control "~:@>")) + (setq wanted + (simple-condition-format-control + condition))))) + then ;; format control doesn't match + (format *error-output* "~ +Reason: the format-control was incorrect.~%") + (format *error-output* " wanted: ~s~%" wanted) + (format *error-output* " got: ~s~%" got) + elseif (and format-arguments + (not (equal + (setq got format-arguments) + (setq wanted + (simple-condition-format-arguments + condition))))) + then (format *error-output* "~ +Reason: the format-arguments were incorrect.~%") + (format *error-output* " wanted: ~s~%" wanted) + (format *error-output* " got: ~s~%" got) + else ;; what else???? + (error "internal-error")) + else (let ((*print-length* 50) + (*print-level* 10)) + (if* wanted-message + then (format *error-output* + " wanted: ~a~%" wanted-message) + else (if* (not multiple-values) + then (format *error-output* + " wanted: ~s~%" + expected-result) + else (format + *error-output* + " wanted values: ~{~s~^, ~}~%" + expected-result))) + (if* got-message + then (format *error-output* + " got: ~a~%" got-message) + else (if* (not multiple-values) + then (format *error-output* " got: ~s~%" + (second test-results)) + else (format + *error-output* + " got values: ~{~s~^, ~}~%" + (cdr test-results)))))) + (when fail-info + (format *error-output* "Additional info: ~a~%" fail-info)) + (incf *test-errors*) + (when *break-on-test-failures* + (break "~a is non-nil." '*break-on-test-failures*)) + else (when known-failure + (format *error-output* + "~&Expected test failure for ~s did not occur.~%" + test-form) + (when fail-info + (format *error-output* "Additional info: ~a~%" fail-info)) + (setq fail t)) + (incf *test-successes*)) + (not fail))) + +(defmacro with-tests ((&key (name "unnamed")) &body body) + (let ((g-name (gensym))) + `(flet ((doit () ,@body)) + (let ((,g-name ,name) + (*test-errors* 0) + (*test-successes* 0) + (*test-unexpected-failures* 0)) + (format *error-output* "Begin ~a test~%" ,g-name) + (if* *break-on-test-failures* + then (doit) + else (handler-case (doit) + (error (c) + (format + *error-output* + "~ +~&Test ~a aborted by signalling an uncaught error:~%~a~%" + ,g-name c)))) + #+allegro + (let ((state (sys:gsgc-switch :print))) + (setf (sys:gsgc-switch :print) nil) + (format t "~&**********************************~%" ,g-name) + (format t "End ~a test~%" ,g-name) + (format t "Errors detected in this test: ~s " *test-errors*) + (unless (zerop *test-unexpected-failures*) + (format t "UNEXPECTED: ~s" *test-unexpected-failures*)) + (format t "~%Successes this test:~s~%" *test-successes*) + (setf (sys:gsgc-switch :print) state)) + #-allegro + (progn + (format t "~&**********************************~%" ,g-name) + (format t "End ~a test~%" ,g-name) + (format t "Errors detected in this test: ~s " *test-errors*) + (unless (zerop *test-unexpected-failures*) + (format t "UNEXPECTED: ~s" *test-unexpected-failures*)) + (format t "~%Successes this test:~s~%" *test-successes*)) + )))) + +(provide :tester #+module-versions 1.1) diff --git a/test-suite/old-tests/interactive-test.cl b/test-suite/old-tests/interactive-test.cl deleted file mode 100644 index c55e75e..0000000 --- a/test-suite/old-tests/interactive-test.cl +++ /dev/null @@ -1,138 +0,0 @@ -;;;; -*- 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: interactive-test.cl,v 1.1 2002/04/20 22:51:42 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) - - -(defvar *config-pathname* (make-pathname :name "test" - :type "config" - :defaults *load-truename*)) -(defparameter *config* nil) - -(defun do-test (&optional (interactive nil)) - (if interactive - (test-interactive) - (if (probe-file *config-pathname*) - (with-open-file (stream *config-pathname* :direction :input) - (setq *config* (read stream)) - (test-automated *config*)) - (test-interactive)))) - -(defun test-interactive () - (do ((done nil)) - (done) - (multiple-value-bind (spec type) (get-spec-and-type) - (if spec - (clsql-test-table spec type) - (setq done t))))) - -(defun test-automated (config) - (dolist (elem config) - (let ((type (car elem)) - (spec (cadr elem))) - #-allegro - (unless (eq type :aodbc) - (clsql-test-table spec type)) - #+allegro - (clsql-test-table spec type))) - ) - - -(defun create-test-table (db) - (ignore-errors - (clsql:execute-command - "DROP TABLE test_clsql" :database db)) - (clsql:execute-command - "CREATE TABLE test_clsql (n integer, n_pi float, n_pi_str CHAR(20))" - :database db) - (dotimes (i 11) - (let ((n (- i 5))) - (clsql:execute-command - (format nil "INSERT INTO test_clsql VALUES (~a,~a,'~a')" - n (clsql:float-to-sql-string (* pi n)) - (clsql:float-to-sql-string (* pi n))) - :database db)))) - -(defun drop-test-table (db) - (clsql:execute-command "DROP TABLE test_clsql")) - -(defun clsql-test-table (spec type) - (when (eq type :mysql) - (test-clsql-mysql spec)) - (let ((db (clsql:connect spec :database-type type :if-exists :new))) - (unwind-protect - (progn - (create-test-table db) - (pprint (clsql:query "select * from test_clsql" - :database db - :types :auto)) - (pprint (clsql:map-query 'vector #'list "select * from test_clsql" - :database db - :types :auto)) ;;'(:int :double t))) - (drop-test-table db)) - (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 :full-set t :types nil))) - (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))) - - -(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) - (get-spec-for-type (read-from-string type-string))))) - -(defun get-spec-for-type (type) - (let ((spec (get-spec-using-format type - (ecase type - ((:mysql :postgresql :postgresql-socket) - '("host" "database" "user" "password")) - (:aodbc - '("dsn" "user" "password")))))) - (values spec type))) - - -(defun get-spec-using-format (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))) diff --git a/test-suite/old-tests/interactive-test.lisp b/test-suite/old-tests/interactive-test.lisp new file mode 100644 index 0000000..420c3ff --- /dev/null +++ b/test-suite/old-tests/interactive-test.lisp @@ -0,0 +1,138 @@ +;;;; -*- 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: interactive-test.lisp,v 1.1 2002/09/30 10:19:24 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) + + +(defvar *config-pathname* (make-pathname :name "test" + :type "config" + :defaults *load-truename*)) +(defparameter *config* nil) + +(defun do-test (&optional (interactive nil)) + (if interactive + (test-interactive) + (if (probe-file *config-pathname*) + (with-open-file (stream *config-pathname* :direction :input) + (setq *config* (read stream)) + (test-automated *config*)) + (test-interactive)))) + +(defun test-interactive () + (do ((done nil)) + (done) + (multiple-value-bind (spec type) (get-spec-and-type) + (if spec + (clsql-test-table spec type) + (setq done t))))) + +(defun test-automated (config) + (dolist (elem config) + (let ((type (car elem)) + (spec (cadr elem))) + #-allegro + (unless (eq type :aodbc) + (clsql-test-table spec type)) + #+allegro + (clsql-test-table spec type))) + ) + + +(defun create-test-table (db) + (ignore-errors + (clsql:execute-command + "DROP TABLE test_clsql" :database db)) + (clsql:execute-command + "CREATE TABLE test_clsql (n integer, n_pi float, n_pi_str CHAR(20))" + :database db) + (dotimes (i 11) + (let ((n (- i 5))) + (clsql:execute-command + (format nil "INSERT INTO test_clsql VALUES (~a,~a,'~a')" + n (clsql:float-to-sql-string (* pi n)) + (clsql:float-to-sql-string (* pi n))) + :database db)))) + +(defun drop-test-table (db) + (clsql:execute-command "DROP TABLE test_clsql")) + +(defun clsql-test-table (spec type) + (when (eq type :mysql) + (test-clsql-mysql spec)) + (let ((db (clsql:connect spec :database-type type :if-exists :new))) + (unwind-protect + (progn + (create-test-table db) + (pprint (clsql:query "select * from test_clsql" + :database db + :types :auto)) + (pprint (clsql:map-query 'vector #'list "select * from test_clsql" + :database db + :types :auto)) ;;'(:int :double t))) + (drop-test-table db)) + (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 :full-set t :types nil))) + (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))) + + +(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) + (get-spec-for-type (read-from-string type-string))))) + +(defun get-spec-for-type (type) + (let ((spec (get-spec-using-format type + (ecase type + ((:mysql :postgresql :postgresql-socket) + '("host" "database" "user" "password")) + (:aodbc + '("dsn" "user" "password")))))) + (values spec type))) + + +(defun get-spec-using-format (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))) diff --git a/test-suite/old-tests/xptest-clsql.cl b/test-suite/old-tests/xptest-clsql.cl deleted file mode 100644 index 67c5a58..0000000 --- a/test-suite/old-tests/xptest-clsql.cl +++ /dev/null @@ -1,224 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: xptest-clsql.cl -;;;; Purpose: Test of CLSQL using XPTest package -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Mar 2002 -;;;; -;;;; $Id: xptest-clsql.cl,v 1.1 2002/04/20 22:51:42 kevin Exp $ -;;;; -;;;; The XPTest package can be downloaded from -;;;; http://alpha.onshored.com/lisp-software/ -;;;; -;;;; 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. -;;;; ************************************************************************* - - -;;; This test suite looks for a configuration file named "test.config" -;;; This file contains a single a-list that specifies the connection -;;; specs for each database type to be tested. For example, to test all -;;; platforms, a sample "test.config" may look like: -;;; -;;; ((:mysql ("localhost" "a-mysql-db" "user1" "secret")) -;;; (:aodbc ("my-dsn" "a-user" "pass")) -;;; (:paostgresql ("localhost" "another-db" "user2" "dont-tell")) -;;; (:postgresql-socket ("pg-server" "a-db-name" "user" "secret-password"))) - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :cl-user) -(mk:load-system "XPTest") - -(in-package :clsql-user) -(use-package :xptest) - -(def-test-fixture clsql-fixture () - ((aodbc-spec :accessor aodbc-spec) - (mysql-spec :accessor mysql-spec) - (pgsql-spec :accessor pgsql-spec) - (pgsql-socket-spec :accessor pgsql-socket-spec)) - (:documentation "Test fixture for CLSQL testing")) - -(defvar *config-pathname* (make-pathname :name "test" - :type "config" - :defaults *load-truename*)) -(defmethod setup ((fix clsql-fixture)) - (if (probe-file *config-pathname*) - (let (config) - (with-open-file (stream *config-pathname* :direction :input) - (setq config (read stream))) - (setf (aodbc-spec fix) (cadr (assoc :aodbc config))) - (setf (mysql-spec fix) (cadr (assoc :mysql config))) - (setf (pgsql-spec fix) (cadr (assoc :postgresql config))) - (setf (pgsql-socket-spec fix) - (cadr (assoc :postgresql-socket config)))) - (error "XPTest Config file ~S not found" *config-pathname*))) - -(defmethod teardown ((fix clsql-fixture)) - t) - -(defmethod mysql-table-test ((test clsql-fixture)) - (test-table (mysql-spec test) :mysql)) - -(defmethod aodbc-table-test ((test clsql-fixture)) - (test-table (aodbc-spec test) :aodbc)) - -(defmethod pgsql-table-test ((test clsql-fixture)) - (test-table (pgsql-spec test) :postgresql)) - -(defmethod pgsql-socket-table-test ((test clsql-fixture)) - (test-table (pgsql-socket-spec test) :postgresql-socket)) - - -(defmethod test-table (spec type) - (when spec - (let ((db (clsql:connect spec :database-type type :if-exists :new))) - (unwind-protect - (progn - (create-test-table db) - (dolist (row (query "select * from test_clsql" :database db :types :auto)) - (test-table-row row :auto)) - (dolist (row (query "select * from test_clsql" :database db :types nil)) - (test-table-row row nil)) - (loop for row across (map-query 'vector #'list "select * from test_clsql" - :database db :types :auto) - do (test-table-row row :auto)) - (loop for row across (map-query 'vector #'list "select * from test_clsql" - :database db :types nil) - do (test-table-row row nil)) - (loop for row in (map-query 'list #'list "select * from test_clsql" - :database db :types nil) - do (test-table-row row nil)) - (loop for row in (map-query 'list #'list "select * from test_clsql" - :database db :types :auto) - do (test-table-row row :auto)) - (when (map-query nil #'list "select * from test_clsql" - :database db :types :auto) - (failure "Expected NIL result from map-query nil")) - (do-query ((int float bigint str) "select * from test_clsql") - (test-table-row (list int float bigint str) nil)) - (do-query ((int float bigint str) "select * from test_clsql" :types :auto) - (test-table-row (list int float bigint str) :auto)) - (drop-test-table db) - ) - (disconnect :database db))))) - - -(defmethod mysql-low-level ((test clsql-fixture)) - (let ((spec (mysql-spec test))) - (when 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 (number-to-sql-string (sqrt i)) - (number-to-sql-string (sqrt i))) - db)) - (let ((res (clsql-mysql::database-query-result-set "select * from test_clsql" db :full-set t :types nil))) - (unless (= 10 (mysql:mysql-num-rows (clsql-mysql::mysql-result-set-res-ptr res))) - (failure "Error calling mysql-num-rows")) - (clsql-mysql::database-dump-result-set res db)) - (clsql-mysql::database-execute-command "DROP TABLE test_clsql" db) - (clsql-mysql::database-disconnect db))))) - -(defparameter clsql-test-suite - (make-test-suite - "CLSQL Test Suite" - "Basic test suite for database operations." - ("MySQL Low Level Interface" 'clsql-fixture - :test-thunk 'mysql-low-level - :description "A test of MySQL low-level interface") - ("MySQL Table" 'clsql-fixture - :test-thunk 'mysql-table-test - :description "A test of MySQL") - ("PostgreSQL Table" 'clsql-fixture - :test-thunk 'pgsql-table-test - :description "A test of PostgreSQL tables") - ("PostgreSQL Socket Table" 'clsql-fixture - :test-thunk 'pgsql-socket-table-test - :description "A test of PostgreSQL Socket tables") - )) - -#+allegro -(add-test (make-test-case "AODBC table test" 'clsql-fixture - :test-thunk 'aodbc-table-test - :description "Test AODBC table") - clsql-test-suite) - -;;;; Testing functions - -(defun transform-float-1 (i) - (* i (abs (/ i 2)) (expt 10 (* 2 i)))) - -(defun transform-bigint-1 (i) - (* i (expt 10 (* 3 (abs i))))) - -(defun create-test-table (db) - (ignore-errors - (clsql:execute-command - "DROP TABLE test_clsql" :database db)) - (clsql:execute-command - "CREATE TABLE test_clsql (t_int integer, t_float float, t_bigint BIGINT, t_str CHAR(30))" - :database db) - (dotimes (i 11) - (let* ((test-int (- i 5)) - (test-flt (transform-float-1 test-int))) - (clsql:execute-command - (format nil "INSERT INTO test_clsql VALUES (~a,~a,~a,'~a')" - test-int - (number-to-sql-string test-flt) - (transform-bigint-1 test-int) - (number-to-sql-string test-flt) - ) - :database db)))) - -(defun parse-double (num-str) - (let ((*read-default-float-format* 'double-float)) - (coerce (read-from-string num-str) 'double-float))) - -(defun test-table-row (row types) - (unless (and (listp row) - (= 4 (length row))) - (failure "Row ~S is incorrect format" row)) - (destructuring-bind (int float bigint str) row - (cond - ((eq types :auto) - (unless (and (integerp int) - (typep float 'double-float) - (integerp bigint) - (stringp str)) - (failure "Incorrect field type for row ~S" row))) - ((null types) - (unless (and (stringp int) - (stringp float) - (stringp bigint) - (stringp str)) - (failure "Incorrect field type for row ~S" row)) - (setq int (parse-integer int)) - (setq bigint (parse-integer bigint)) - (setq float (parse-double float))) - ((listp types) - (error "NYI") - ) - (t - (failure "Invalid types field (~S) passed to test-table-row" types))) - (unless (= float (transform-float-1 int)) - (failure "Wrong float value ~A for int ~A (row ~S)" float int row)) - (unless (= float (parse-double str)) - (failure "Wrong string value ~A" str)))) - - -(defun drop-test-table (db) - (clsql:execute-command "DROP TABLE test_clsql")) - -(report-result (run-test clsql-test-suite :handle-errors nil) :verbose t) - - diff --git a/test-suite/old-tests/xptest-clsql.lisp b/test-suite/old-tests/xptest-clsql.lisp new file mode 100644 index 0000000..c301941 --- /dev/null +++ b/test-suite/old-tests/xptest-clsql.lisp @@ -0,0 +1,224 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: xptest-clsql.cl +;;;; Purpose: Test of CLSQL using XPTest package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id: xptest-clsql.lisp,v 1.1 2002/09/30 10:19:24 kevin Exp $ +;;;; +;;;; The XPTest package can be downloaded from +;;;; http://alpha.onshored.com/lisp-software/ +;;;; +;;;; 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. +;;;; ************************************************************************* + + +;;; This test suite looks for a configuration file named "test.config" +;;; This file contains a single a-list that specifies the connection +;;; specs for each database type to be tested. For example, to test all +;;; platforms, a sample "test.config" may look like: +;;; +;;; ((:mysql ("localhost" "a-mysql-db" "user1" "secret")) +;;; (:aodbc ("my-dsn" "a-user" "pass")) +;;; (:paostgresql ("localhost" "another-db" "user2" "dont-tell")) +;;; (:postgresql-socket ("pg-server" "a-db-name" "user" "secret-password"))) + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :cl-user) +(mk:load-system "XPTest") + +(in-package :clsql-user) +(use-package :xptest) + +(def-test-fixture clsql-fixture () + ((aodbc-spec :accessor aodbc-spec) + (mysql-spec :accessor mysql-spec) + (pgsql-spec :accessor pgsql-spec) + (pgsql-socket-spec :accessor pgsql-socket-spec)) + (:documentation "Test fixture for CLSQL testing")) + +(defvar *config-pathname* (make-pathname :name "test" + :type "config" + :defaults *load-truename*)) +(defmethod setup ((fix clsql-fixture)) + (if (probe-file *config-pathname*) + (let (config) + (with-open-file (stream *config-pathname* :direction :input) + (setq config (read stream))) + (setf (aodbc-spec fix) (cadr (assoc :aodbc config))) + (setf (mysql-spec fix) (cadr (assoc :mysql config))) + (setf (pgsql-spec fix) (cadr (assoc :postgresql config))) + (setf (pgsql-socket-spec fix) + (cadr (assoc :postgresql-socket config)))) + (error "XPTest Config file ~S not found" *config-pathname*))) + +(defmethod teardown ((fix clsql-fixture)) + t) + +(defmethod mysql-table-test ((test clsql-fixture)) + (test-table (mysql-spec test) :mysql)) + +(defmethod aodbc-table-test ((test clsql-fixture)) + (test-table (aodbc-spec test) :aodbc)) + +(defmethod pgsql-table-test ((test clsql-fixture)) + (test-table (pgsql-spec test) :postgresql)) + +(defmethod pgsql-socket-table-test ((test clsql-fixture)) + (test-table (pgsql-socket-spec test) :postgresql-socket)) + + +(defmethod test-table (spec type) + (when spec + (let ((db (clsql:connect spec :database-type type :if-exists :new))) + (unwind-protect + (progn + (create-test-table db) + (dolist (row (query "select * from test_clsql" :database db :types :auto)) + (test-table-row row :auto)) + (dolist (row (query "select * from test_clsql" :database db :types nil)) + (test-table-row row nil)) + (loop for row across (map-query 'vector #'list "select * from test_clsql" + :database db :types :auto) + do (test-table-row row :auto)) + (loop for row across (map-query 'vector #'list "select * from test_clsql" + :database db :types nil) + do (test-table-row row nil)) + (loop for row in (map-query 'list #'list "select * from test_clsql" + :database db :types nil) + do (test-table-row row nil)) + (loop for row in (map-query 'list #'list "select * from test_clsql" + :database db :types :auto) + do (test-table-row row :auto)) + (when (map-query nil #'list "select * from test_clsql" + :database db :types :auto) + (failure "Expected NIL result from map-query nil")) + (do-query ((int float bigint str) "select * from test_clsql") + (test-table-row (list int float bigint str) nil)) + (do-query ((int float bigint str) "select * from test_clsql" :types :auto) + (test-table-row (list int float bigint str) :auto)) + (drop-test-table db) + ) + (disconnect :database db))))) + + +(defmethod mysql-low-level ((test clsql-fixture)) + (let ((spec (mysql-spec test))) + (when 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 (number-to-sql-string (sqrt i)) + (number-to-sql-string (sqrt i))) + db)) + (let ((res (clsql-mysql::database-query-result-set "select * from test_clsql" db :full-set t :types nil))) + (unless (= 10 (mysql:mysql-num-rows (clsql-mysql::mysql-result-set-res-ptr res))) + (failure "Error calling mysql-num-rows")) + (clsql-mysql::database-dump-result-set res db)) + (clsql-mysql::database-execute-command "DROP TABLE test_clsql" db) + (clsql-mysql::database-disconnect db))))) + +(defparameter clsql-test-suite + (make-test-suite + "CLSQL Test Suite" + "Basic test suite for database operations." + ("MySQL Low Level Interface" 'clsql-fixture + :test-thunk 'mysql-low-level + :description "A test of MySQL low-level interface") + ("MySQL Table" 'clsql-fixture + :test-thunk 'mysql-table-test + :description "A test of MySQL") + ("PostgreSQL Table" 'clsql-fixture + :test-thunk 'pgsql-table-test + :description "A test of PostgreSQL tables") + ("PostgreSQL Socket Table" 'clsql-fixture + :test-thunk 'pgsql-socket-table-test + :description "A test of PostgreSQL Socket tables") + )) + +#+allegro +(add-test (make-test-case "AODBC table test" 'clsql-fixture + :test-thunk 'aodbc-table-test + :description "Test AODBC table") + clsql-test-suite) + +;;;; Testing functions + +(defun transform-float-1 (i) + (* i (abs (/ i 2)) (expt 10 (* 2 i)))) + +(defun transform-bigint-1 (i) + (* i (expt 10 (* 3 (abs i))))) + +(defun create-test-table (db) + (ignore-errors + (clsql:execute-command + "DROP TABLE test_clsql" :database db)) + (clsql:execute-command + "CREATE TABLE test_clsql (t_int integer, t_float float, t_bigint BIGINT, t_str CHAR(30))" + :database db) + (dotimes (i 11) + (let* ((test-int (- i 5)) + (test-flt (transform-float-1 test-int))) + (clsql:execute-command + (format nil "INSERT INTO test_clsql VALUES (~a,~a,~a,'~a')" + test-int + (number-to-sql-string test-flt) + (transform-bigint-1 test-int) + (number-to-sql-string test-flt) + ) + :database db)))) + +(defun parse-double (num-str) + (let ((*read-default-float-format* 'double-float)) + (coerce (read-from-string num-str) 'double-float))) + +(defun test-table-row (row types) + (unless (and (listp row) + (= 4 (length row))) + (failure "Row ~S is incorrect format" row)) + (destructuring-bind (int float bigint str) row + (cond + ((eq types :auto) + (unless (and (integerp int) + (typep float 'double-float) + (integerp bigint) + (stringp str)) + (failure "Incorrect field type for row ~S" row))) + ((null types) + (unless (and (stringp int) + (stringp float) + (stringp bigint) + (stringp str)) + (failure "Incorrect field type for row ~S" row)) + (setq int (parse-integer int)) + (setq bigint (parse-integer bigint)) + (setq float (parse-double float))) + ((listp types) + (error "NYI") + ) + (t + (failure "Invalid types field (~S) passed to test-table-row" types))) + (unless (= float (transform-float-1 int)) + (failure "Wrong float value ~A for int ~A (row ~S)" float int row)) + (unless (= float (parse-double str)) + (failure "Wrong string value ~A" str)))) + + +(defun drop-test-table (db) + (clsql:execute-command "DROP TABLE test_clsql")) + +(report-result (run-test clsql-test-suite :handle-errors nil) :verbose t) + + diff --git a/test-suite/tester-clsql.cl b/test-suite/tester-clsql.cl deleted file mode 100644 index ad121e4..0000000 --- a/test-suite/tester-clsql.cl +++ /dev/null @@ -1,239 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: tester-clsql.cl -;;;; Purpose: Automated test of CLSQL using ACL's tester -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Mar 2002 -;;;; -;;;; $Id: tester-clsql.cl,v 1.9 2002/09/30 01:57:32 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -;;; This test suite looks for a configuration file named "test.config" -;;; This file contains a single a-list that specifies the connection -;;; specs for each database type to be tested. For example, to test all -;;; platforms, a sample "test.config" may look like: -;;; -;;; ((:mysql ("localhost" "a-mysql-db" "user1" "secret")) -;;; (:aodbc ("my-dsn" "a-user" "pass")) -;;; (:postgresql ("localhost" "another-db" "user2" "dont-tell")) -;;; (:postgresql-socket ("pg-server" "a-db-name" "user" "secret-password"))) - - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :cl-user) - -(unless (find-package :util.test) - (load (make-pathname :name "acl-compat-tester" :type "cl" - :defaults *load-truename*))) - -(in-package :clsql-user) -(use-package :util.test) - -(defvar *config-pathname* (make-pathname :name "test" - :type "config" - :defaults *load-truename*)) - -(defclass conn-specs () - ((aodbc-spec :accessor aodbc-spec) - (mysql-spec :accessor mysql-spec) - (pgsql-spec :accessor pgsql-spec) - (pgsql-socket-spec :accessor pgsql-socket-spec)) - (:documentation "Test fixture for CLSQL testing")) - - -(defun read-specs (&optional (path *config-pathname*)) - (if (probe-file path) - (with-open-file (stream path :direction :input) - (let ((config (read stream)) - (specs (make-instance 'conn-specs))) - (setf (aodbc-spec specs) (cadr (assoc :aodbc config))) - (setf (mysql-spec specs) (cadr (assoc :mysql config))) - (setf (pgsql-spec specs) (cadr (assoc :postgresql config))) - (setf (pgsql-socket-spec specs) - (cadr (assoc :postgresql-socket config))) - specs)) - (error "CLSQL tester config file ~S not found" path))) - -(defmethod mysql-table-test ((test conn-specs)) - (test-table (mysql-spec test) :mysql)) - -(defmethod aodbc-table-test ((test conn-specs)) - (test-table (aodbc-spec test) :aodbc)) - -(defmethod pgsql-table-test ((test conn-specs)) - (test-table (pgsql-spec test) :postgresql)) - -(defmethod pgsql-socket-table-test ((test conn-specs)) - (test-table (pgsql-socket-spec test) :postgresql-socket)) - -(defmethod test-table (spec type) - (when spec - (let ((db (clsql:connect spec :database-type type :if-exists :new))) - (unwind-protect - (progn - (create-test-table db) - (dolist (row (query "select * from test_clsql" :database db :types :auto)) - (test-table-row row :auto type)) - (dolist (row (query "select * from test_clsql" :database db :types nil)) - (test-table-row row nil type)) - (loop for row across (map-query 'vector #'list "select * from test_clsql" - :database db :types :auto) - do (test-table-row row :auto type)) - (loop for row across (map-query 'vector #'list "select * from test_clsql" - :database db :types nil) - do (test-table-row row nil type)) - (loop for row in (map-query 'list #'list "select * from test_clsql" - :database db :types nil) - do (test-table-row row nil type)) - (loop for row in (map-query 'list #'list "select * from test_clsql" - :database db :types :auto) - do (test-table-row row :auto type)) - (test (map-query nil #'list "select * from test_clsql" - :database db :types :auto) - nil - :fail-info "Expected NIL result from map-query nil") - (do-query ((int float bigint str) "select * from test_clsql") - (test-table-row (list int float bigint str) nil type)) - (do-query ((int float bigint str) "select * from test_clsql" :types :auto) - (test-table-row (list int float bigint str) :auto type)) - (drop-test-table db) - ) - (disconnect :database db))))) - - -(defmethod mysql-low-level ((test conn-specs)) - (let ((spec (mysql-spec test))) - (when 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 (clsql:number-to-sql-string (sqrt i)) - (clsql:number-to-sql-string (sqrt i))) - db)) - (let ((res (clsql-mysql::database-query-result-set "select * from test_clsql" db :full-set t :types nil))) - (test (mysql:mysql-num-rows - (clsql-mysql::mysql-result-set-res-ptr res)) - 10 - :test #'eql - :fail-info "Error calling mysql-num-rows") - (clsql-mysql::database-dump-result-set res db)) - (clsql-mysql::database-execute-command "DROP TABLE test_clsql" db) - (clsql-mysql::database-disconnect db))))) - - - -;;;; Testing functions - -(defun transform-float-1 (i) - (coerce (* i (abs (/ i 2)) (expt 10 (* 2 i))) 'double-float)) - -(defun transform-bigint-1 (i) - (* i (expt 10 (* 3 (abs i))))) - -(defun create-test-table (db) - (ignore-errors - (clsql:execute-command - "DROP TABLE test_clsql" :database db)) - (clsql:execute-command - "CREATE TABLE test_clsql (t_int integer, t_float float, t_bigint BIGINT, t_str CHAR(30))" - :database db) - (dotimes (i 11) - (let* ((test-int (- i 5)) - (test-flt (transform-float-1 test-int))) - (clsql:execute-command - (format nil "INSERT INTO test_clsql VALUES (~a,~a,~a,'~a')" - test-int - (number-to-sql-string test-flt) - (transform-bigint-1 test-int) - (number-to-sql-string test-flt) - ) - :database db)))) - -(defun parse-double (num-str) - (let ((*read-default-float-format* 'double-float)) - (coerce (read-from-string num-str) 'double-float))) - -(defun test-table-row (row types db-type) - (test (and (listp row) - (= 4 (length row))) - t - :fail-info - (format nil "Row ~S is incorrect format" row)) - (destructuring-bind (int float bigint str) row - (cond - ((eq types :auto) - (test (and (integerp int) - (typep float 'double-float) - (or (eq db-type :aodbc) ;; aodbc doesn't handle bigint conversions - (integerp bigint)) - (stringp str)) - t - :fail-info - (format nil "Incorrect field type for row ~S (types :auto)" row))) - ((null types) - (test (and (stringp int) - (stringp float) - (stringp bigint) - (stringp str)) - t - :fail-info - (format nil "Incorrect field type for row ~S (types nil)" row)) - (setq int (parse-integer int)) - (setq bigint (parse-integer bigint)) - (setq float (parse-double float))) - ((listp types) - (error "NYI") - ) - (t - (test t nil - :fail-info - (format nil "Invalid types field (~S) passed to test-table-row" types)))) - (test (transform-float-1 int) - float - :test #'eql - :fail-info - (format nil "Wrong float value ~A for int ~A (row ~S)" float int row)) - (test float - (parse-double str) - :test #'double-float-equal - :fail-info (format nil "Wrong string value ~A for double ~A~%Row: ~S" - str float row)))) - - -(defun double-float-equal (a b) - (if (zerop a) - (if (zerop b) - t - nil) - (let ((diff (abs (/ (- a b) a)))) - (if (> diff (* 10 double-float-epsilon)) - nil - t)))) - -(defun drop-test-table (db) - (clsql:execute-command "DROP TABLE test_clsql" :database db)) - -(defun do-test () - (let ((specs (read-specs))) - (with-tests (:name "CLSQL") - (mysql-low-level specs) - (mysql-table-test specs) - (pgsql-table-test specs) - (pgsql-socket-table-test specs) - (aodbc-table-test specs) - ))) - - -(do-test) diff --git a/test-suite/tester-clsql.lisp b/test-suite/tester-clsql.lisp new file mode 100644 index 0000000..914c3f6 --- /dev/null +++ b/test-suite/tester-clsql.lisp @@ -0,0 +1,239 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: tester-clsql.cl +;;;; Purpose: Automated test of CLSQL using ACL's tester +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id: tester-clsql.lisp,v 1.1 2002/09/30 10:19:23 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. +;;;; ************************************************************************* + +;;; This test suite looks for a configuration file named "test.config" +;;; This file contains a single a-list that specifies the connection +;;; specs for each database type to be tested. For example, to test all +;;; platforms, a sample "test.config" may look like: +;;; +;;; ((:mysql ("localhost" "a-mysql-db" "user1" "secret")) +;;; (:aodbc ("my-dsn" "a-user" "pass")) +;;; (:postgresql ("localhost" "another-db" "user2" "dont-tell")) +;;; (:postgresql-socket ("pg-server" "a-db-name" "user" "secret-password"))) + + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :cl-user) + +(unless (find-package :util.test) + (load (make-pathname :name "acl-compat-tester" :type "cl" + :defaults *load-truename*))) + +(in-package :clsql-user) +(use-package :util.test) + +(defvar *config-pathname* (make-pathname :name "test" + :type "config" + :defaults *load-truename*)) + +(defclass conn-specs () + ((aodbc-spec :accessor aodbc-spec) + (mysql-spec :accessor mysql-spec) + (pgsql-spec :accessor pgsql-spec) + (pgsql-socket-spec :accessor pgsql-socket-spec)) + (:documentation "Test fixture for CLSQL testing")) + + +(defun read-specs (&optional (path *config-pathname*)) + (if (probe-file path) + (with-open-file (stream path :direction :input) + (let ((config (read stream)) + (specs (make-instance 'conn-specs))) + (setf (aodbc-spec specs) (cadr (assoc :aodbc config))) + (setf (mysql-spec specs) (cadr (assoc :mysql config))) + (setf (pgsql-spec specs) (cadr (assoc :postgresql config))) + (setf (pgsql-socket-spec specs) + (cadr (assoc :postgresql-socket config))) + specs)) + (error "CLSQL tester config file ~S not found" path))) + +(defmethod mysql-table-test ((test conn-specs)) + (test-table (mysql-spec test) :mysql)) + +(defmethod aodbc-table-test ((test conn-specs)) + (test-table (aodbc-spec test) :aodbc)) + +(defmethod pgsql-table-test ((test conn-specs)) + (test-table (pgsql-spec test) :postgresql)) + +(defmethod pgsql-socket-table-test ((test conn-specs)) + (test-table (pgsql-socket-spec test) :postgresql-socket)) + +(defmethod test-table (spec type) + (when spec + (let ((db (clsql:connect spec :database-type type :if-exists :new))) + (unwind-protect + (progn + (create-test-table db) + (dolist (row (query "select * from test_clsql" :database db :types :auto)) + (test-table-row row :auto type)) + (dolist (row (query "select * from test_clsql" :database db :types nil)) + (test-table-row row nil type)) + (loop for row across (map-query 'vector #'list "select * from test_clsql" + :database db :types :auto) + do (test-table-row row :auto type)) + (loop for row across (map-query 'vector #'list "select * from test_clsql" + :database db :types nil) + do (test-table-row row nil type)) + (loop for row in (map-query 'list #'list "select * from test_clsql" + :database db :types nil) + do (test-table-row row nil type)) + (loop for row in (map-query 'list #'list "select * from test_clsql" + :database db :types :auto) + do (test-table-row row :auto type)) + (test (map-query nil #'list "select * from test_clsql" + :database db :types :auto) + nil + :fail-info "Expected NIL result from map-query nil") + (do-query ((int float bigint str) "select * from test_clsql") + (test-table-row (list int float bigint str) nil type)) + (do-query ((int float bigint str) "select * from test_clsql" :types :auto) + (test-table-row (list int float bigint str) :auto type)) + (drop-test-table db) + ) + (disconnect :database db))))) + + +(defmethod mysql-low-level ((test conn-specs)) + (let ((spec (mysql-spec test))) + (when 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 (clsql:number-to-sql-string (sqrt i)) + (clsql:number-to-sql-string (sqrt i))) + db)) + (let ((res (clsql-mysql::database-query-result-set "select * from test_clsql" db :full-set t :types nil))) + (test (mysql:mysql-num-rows + (clsql-mysql::mysql-result-set-res-ptr res)) + 10 + :test #'eql + :fail-info "Error calling mysql-num-rows") + (clsql-mysql::database-dump-result-set res db)) + (clsql-mysql::database-execute-command "DROP TABLE test_clsql" db) + (clsql-mysql::database-disconnect db))))) + + + +;;;; Testing functions + +(defun transform-float-1 (i) + (coerce (* i (abs (/ i 2)) (expt 10 (* 2 i))) 'double-float)) + +(defun transform-bigint-1 (i) + (* i (expt 10 (* 3 (abs i))))) + +(defun create-test-table (db) + (ignore-errors + (clsql:execute-command + "DROP TABLE test_clsql" :database db)) + (clsql:execute-command + "CREATE TABLE test_clsql (t_int integer, t_float float, t_bigint BIGINT, t_str CHAR(30))" + :database db) + (dotimes (i 11) + (let* ((test-int (- i 5)) + (test-flt (transform-float-1 test-int))) + (clsql:execute-command + (format nil "INSERT INTO test_clsql VALUES (~a,~a,~a,'~a')" + test-int + (number-to-sql-string test-flt) + (transform-bigint-1 test-int) + (number-to-sql-string test-flt) + ) + :database db)))) + +(defun parse-double (num-str) + (let ((*read-default-float-format* 'double-float)) + (coerce (read-from-string num-str) 'double-float))) + +(defun test-table-row (row types db-type) + (test (and (listp row) + (= 4 (length row))) + t + :fail-info + (format nil "Row ~S is incorrect format" row)) + (destructuring-bind (int float bigint str) row + (cond + ((eq types :auto) + (test (and (integerp int) + (typep float 'double-float) + (or (eq db-type :aodbc) ;; aodbc doesn't handle bigint conversions + (integerp bigint)) + (stringp str)) + t + :fail-info + (format nil "Incorrect field type for row ~S (types :auto)" row))) + ((null types) + (test (and (stringp int) + (stringp float) + (stringp bigint) + (stringp str)) + t + :fail-info + (format nil "Incorrect field type for row ~S (types nil)" row)) + (setq int (parse-integer int)) + (setq bigint (parse-integer bigint)) + (setq float (parse-double float))) + ((listp types) + (error "NYI") + ) + (t + (test t nil + :fail-info + (format nil "Invalid types field (~S) passed to test-table-row" types)))) + (test (transform-float-1 int) + float + :test #'eql + :fail-info + (format nil "Wrong float value ~A for int ~A (row ~S)" float int row)) + (test float + (parse-double str) + :test #'double-float-equal + :fail-info (format nil "Wrong string value ~A for double ~A~%Row: ~S" + str float row)))) + + +(defun double-float-equal (a b) + (if (zerop a) + (if (zerop b) + t + nil) + (let ((diff (abs (/ (- a b) a)))) + (if (> diff (* 10 double-float-epsilon)) + nil + t)))) + +(defun drop-test-table (db) + (clsql:execute-command "DROP TABLE test_clsql" :database db)) + +(defun do-test () + (let ((specs (read-specs))) + (with-tests (:name "CLSQL") + (mysql-low-level specs) + (mysql-table-test specs) + (pgsql-table-test specs) + (pgsql-socket-table-test specs) + (aodbc-table-test specs) + ))) + + +(do-test) diff --git a/uffi/clsql-uffi-loader.cl b/uffi/clsql-uffi-loader.cl deleted file mode 100644 index e13bd68..0000000 --- a/uffi/clsql-uffi-loader.cl +++ /dev/null @@ -1,49 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: clsql-uffi-loader.sql -;;;; Purpose: library loader using CLSQL UFFI helper library -;;;; Programmers: Kevin M. Rosenberg -;;;; Date Started: Mar 2002 -;;;; -;;;; $Id: clsql-uffi-loader.cl,v 1.3 2002/09/30 05:32:35 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-uffi) - -(defvar *clsql-uffi-library-filename* - (uffi:find-foreign-library - "clsql-uffi" - `("/usr/lib/clsql/" - "/opt/lisp/clsql/uffi/" - "/home/kevin/debian/src/clsql/uffi/") - :drive-letters '("C" "D" "E" "F" "G"))) - -(defvar *clsql-uffi-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.") - -(defvar *uffi-library-loaded* nil - "T if foreign library was able to be loaded successfully") - -(defun load-uffi-foreign-library () - (if (uffi:load-foreign-library *clsql-uffi-library-filename* - :module "clsql-uffi" - :supporting-libraries - *clsql-uffi-supporting-libraries*) - (setq *uffi-library-loaded* t) - (warn "Unable to load helper library ~A" *clsql-uffi-library-filename*))) - -(load-uffi-foreign-library) - - - diff --git a/uffi/clsql-uffi-loader.lisp b/uffi/clsql-uffi-loader.lisp new file mode 100644 index 0000000..c578329 --- /dev/null +++ b/uffi/clsql-uffi-loader.lisp @@ -0,0 +1,49 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql-uffi-loader.sql +;;;; Purpose: library loader using CLSQL UFFI helper library +;;;; Programmers: Kevin M. Rosenberg +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id: clsql-uffi-loader.lisp,v 1.1 2002/09/30 10:19:24 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-uffi) + +(defvar *clsql-uffi-library-filename* + (uffi:find-foreign-library + "clsql-uffi" + `("/usr/lib/clsql/" + "/opt/lisp/clsql/uffi/" + "/home/kevin/debian/src/clsql/uffi/") + :drive-letters '("C" "D" "E" "F" "G"))) + +(defvar *clsql-uffi-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.") + +(defvar *uffi-library-loaded* nil + "T if foreign library was able to be loaded successfully") + +(defun load-uffi-foreign-library () + (if (uffi:load-foreign-library *clsql-uffi-library-filename* + :module "clsql-uffi" + :supporting-libraries + *clsql-uffi-supporting-libraries*) + (setq *uffi-library-loaded* t) + (warn "Unable to load helper library ~A" *clsql-uffi-library-filename*))) + +(load-uffi-foreign-library) + + + diff --git a/uffi/clsql-uffi-package.cl b/uffi/clsql-uffi-package.cl deleted file mode 100644 index 4b541f9..0000000 --- a/uffi/clsql-uffi-package.cl +++ /dev/null @@ -1,33 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: clsql-uffi-package.cl -;;;; Purpose: Package definitions for common UFFI interface routines -;;;; Programmers: Kevin M. Rosenberg -;;;; Date Started: Mar 2002 -;;;; -;;;; $Id: clsql-uffi-package.cl,v 1.1 2002/09/18 07:50:01 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :cl-user) - -(defpackage :clsql-uffi - (:export - #:canonicalize-type-list - #:convert-raw-field - #:atoi - #:atol - #:atof - #:atol64 - #:make-64-bit-integer - #:split-64-bit-integer) - (:documentation "Common functions for interfaces using UFFI")) - diff --git a/uffi/clsql-uffi-package.lisp b/uffi/clsql-uffi-package.lisp new file mode 100644 index 0000000..9e39e03 --- /dev/null +++ b/uffi/clsql-uffi-package.lisp @@ -0,0 +1,33 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql-uffi-package.cl +;;;; Purpose: Package definitions for common UFFI interface routines +;;;; Programmers: Kevin M. Rosenberg +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id: clsql-uffi-package.lisp,v 1.1 2002/09/30 10:19:24 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 :clsql-uffi + (:export + #:canonicalize-type-list + #:convert-raw-field + #:atoi + #:atol + #:atof + #:atol64 + #:make-64-bit-integer + #:split-64-bit-integer) + (:documentation "Common functions for interfaces using UFFI")) + diff --git a/uffi/clsql-uffi.cl b/uffi/clsql-uffi.cl deleted file mode 100644 index 2d1cd94..0000000 --- a/uffi/clsql-uffi.cl +++ /dev/null @@ -1,103 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: clsql-uffi.cl -;;;; Purpose: Common functions for interfaces using UFFI -;;;; Programmers: Kevin M. Rosenberg -;;;; Date Started: Mar 2002 -;;;; -;;;; $Id: clsql-uffi.cl,v 1.1 2002/09/18 07:50:01 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-uffi) - - -(defun canonicalize-type-list (types auto-list) - "Ensure a field type list meets expectations" - (let ((length-types (length types)) - (new-types '())) - (loop for i from 0 below (length auto-list) - do - (if (>= i length-types) - (push t new-types) ;; types is shorted than num-fields - (push - (case (nth i types) - (:int - (case (nth i auto-list) - (:int32 - :int32) - (:int64 - :int64) - (t - t))) - (:double - (case (nth i auto-list) - (:double - :double) - (t - t))) - (:int32 - (if (eq :int32 (nth i auto-list)) - :int32 - t)) - (:int64 - (if (eq :int64 (nth i auto-list)) - :int64 - t)) - (t - t)) - new-types))) - (nreverse new-types))) - -(uffi:def-function "atoi" - ((str (* :unsigned-char))) - :returning :int) - -(uffi:def-function "atol" - ((str (* :unsigned-char))) - :returning :long) - -(uffi:def-function "atof" - ((str (* :unsigned-char))) - :returning :double) - -(uffi:def-function "atol64" - ((str (* :unsigned-char)) - (high32 (* :int))) - :returning :unsigned-int) - -(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+))) - -(defmacro split-64-bit-integer (int64) - `(values (ash ,int64 -32) (logand ,int64 +2^32-1+))) - -(defun convert-raw-field (char-ptr types index) - (let ((type (if (listp types) - (nth index types) - types))) - (case type - (:double - (atof char-ptr)) - ((or :int32 :int) - (atoi char-ptr)) - (:int64 - (uffi:with-foreign-object (high32-ptr :int) - (let ((low32 (atol64 char-ptr high32-ptr)) - (high32 (uffi:deref-pointer high32-ptr :int))) - (if (zerop high32) - low32 - (make-64-bit-integer high32 low32))))) - (t - (uffi:convert-from-foreign-string char-ptr))))) diff --git a/uffi/clsql-uffi.lisp b/uffi/clsql-uffi.lisp new file mode 100644 index 0000000..98936c0 --- /dev/null +++ b/uffi/clsql-uffi.lisp @@ -0,0 +1,103 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql-uffi.cl +;;;; Purpose: Common functions for interfaces using UFFI +;;;; Programmers: Kevin M. Rosenberg +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id: clsql-uffi.lisp,v 1.1 2002/09/30 10:19:24 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-uffi) + + +(defun canonicalize-type-list (types auto-list) + "Ensure a field type list meets expectations" + (let ((length-types (length types)) + (new-types '())) + (loop for i from 0 below (length auto-list) + do + (if (>= i length-types) + (push t new-types) ;; types is shorted than num-fields + (push + (case (nth i types) + (:int + (case (nth i auto-list) + (:int32 + :int32) + (:int64 + :int64) + (t + t))) + (:double + (case (nth i auto-list) + (:double + :double) + (t + t))) + (:int32 + (if (eq :int32 (nth i auto-list)) + :int32 + t)) + (:int64 + (if (eq :int64 (nth i auto-list)) + :int64 + t)) + (t + t)) + new-types))) + (nreverse new-types))) + +(uffi:def-function "atoi" + ((str (* :unsigned-char))) + :returning :int) + +(uffi:def-function "atol" + ((str (* :unsigned-char))) + :returning :long) + +(uffi:def-function "atof" + ((str (* :unsigned-char))) + :returning :double) + +(uffi:def-function "atol64" + ((str (* :unsigned-char)) + (high32 (* :int))) + :returning :unsigned-int) + +(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+))) + +(defmacro split-64-bit-integer (int64) + `(values (ash ,int64 -32) (logand ,int64 +2^32-1+))) + +(defun convert-raw-field (char-ptr types index) + (let ((type (if (listp types) + (nth index types) + types))) + (case type + (:double + (atof char-ptr)) + ((or :int32 :int) + (atoi char-ptr)) + (:int64 + (uffi:with-foreign-object (high32-ptr :int) + (let ((low32 (atol64 char-ptr high32-ptr)) + (high32 (uffi:deref-pointer high32-ptr :int))) + (if (zerop high32) + low32 + (make-64-bit-integer high32 low32))))) + (t + (uffi:convert-from-foreign-string char-ptr)))))