r2914: rename .cl files
authorKevin M. Rosenberg <kevin@rosenberg.net>
Mon, 30 Sep 2002 10:19:24 +0000 (10:19 +0000)
committerKevin M. Rosenberg <kevin@rosenberg.net>
Mon, 30 Sep 2002 10:19:24 +0000 (10:19 +0000)
84 files changed:
clsql-aodbc.asd
clsql-base.asd
clsql-mysql.asd
clsql-oracle.asd
clsql-postgresql-socket.asd
clsql-postgresql.asd
clsql-uffi.asd
clsql.asd
db-aodbc/aodbc-package.cl [deleted file]
db-aodbc/aodbc-package.lisp [new file with mode: 0644]
db-aodbc/aodbc-sql.cl [deleted file]
db-aodbc/aodbc-sql.lisp [new file with mode: 0644]
db-mysql/mysql-api.cl [deleted file]
db-mysql/mysql-api.lisp [new file with mode: 0644]
db-mysql/mysql-loader.cl [deleted file]
db-mysql/mysql-loader.lisp [new file with mode: 0644]
db-mysql/mysql-package.cl [deleted file]
db-mysql/mysql-package.lisp [new file with mode: 0644]
db-mysql/mysql-sql.cl [deleted file]
db-mysql/mysql-sql.lisp [new file with mode: 0644]
db-mysql/mysql-usql.cl [deleted file]
db-mysql/mysql-usql.lisp [new file with mode: 0644]
db-mysql/testing/mysql-struct-size.cl [deleted file]
db-mysql/testing/mysql-struct-size.lisp [new file with mode: 0644]
db-oracle/alien-resources.cl [deleted file]
db-oracle/alien-resources.lisp [new file with mode: 0644]
db-oracle/oracle-constants.cl [deleted file]
db-oracle/oracle-constants.lisp [new file with mode: 0644]
db-oracle/oracle-loader.cl [deleted file]
db-oracle/oracle-loader.lisp [new file with mode: 0644]
db-oracle/oracle-objects.cl [deleted file]
db-oracle/oracle-objects.lisp [new file with mode: 0644]
db-oracle/oracle-package.cl [deleted file]
db-oracle/oracle-package.lisp [new file with mode: 0644]
db-oracle/oracle-sql.cl [deleted file]
db-oracle/oracle-sql.lisp [new file with mode: 0644]
db-oracle/oracle.cl [deleted file]
db-oracle/oracle.lisp [new file with mode: 0644]
db-postgresql-socket/postgresql-socket-api.cl [deleted file]
db-postgresql-socket/postgresql-socket-api.lisp [new file with mode: 0644]
db-postgresql-socket/postgresql-socket-package.cl [deleted file]
db-postgresql-socket/postgresql-socket-package.lisp [new file with mode: 0644]
db-postgresql-socket/postgresql-socket-sql.cl [deleted file]
db-postgresql-socket/postgresql-socket-sql.lisp [new file with mode: 0644]
db-postgresql/postgresql-api.cl [deleted file]
db-postgresql/postgresql-api.lisp [new file with mode: 0644]
db-postgresql/postgresql-loader.cl [deleted file]
db-postgresql/postgresql-loader.lisp [new file with mode: 0644]
db-postgresql/postgresql-package.cl [deleted file]
db-postgresql/postgresql-package.lisp [new file with mode: 0644]
db-postgresql/postgresql-sql.cl [deleted file]
db-postgresql/postgresql-sql.lisp [new file with mode: 0644]
db-postgresql/postgresql-usql.cl [deleted file]
db-postgresql/postgresql-usql.lisp [new file with mode: 0644]
debian/changelog
debian/rules
sql/functional.cl [deleted file]
sql/functional.lisp [new file with mode: 0644]
sql/loop-extension.cl [deleted file]
sql/loop-extension.lisp [new file with mode: 0644]
sql/package.cl [deleted file]
sql/package.lisp [new file with mode: 0644]
sql/pool.cl [deleted file]
sql/pool.lisp [new file with mode: 0644]
sql/sql.cl [deleted file]
sql/sql.lisp [new file with mode: 0644]
sql/transactions.cl [deleted file]
sql/transactions.lisp [new file with mode: 0644]
sql/usql.cl [deleted file]
sql/usql.lisp [new file with mode: 0644]
test-suite/acl-compat-tester.cl [deleted file]
test-suite/acl-compat-tester.lisp [new file with mode: 0644]
test-suite/old-tests/interactive-test.cl [deleted file]
test-suite/old-tests/interactive-test.lisp [new file with mode: 0644]
test-suite/old-tests/xptest-clsql.cl [deleted file]
test-suite/old-tests/xptest-clsql.lisp [new file with mode: 0644]
test-suite/tester-clsql.cl [deleted file]
test-suite/tester-clsql.lisp [new file with mode: 0644]
uffi/clsql-uffi-loader.cl [deleted file]
uffi/clsql-uffi-loader.lisp [new file with mode: 0644]
uffi/clsql-uffi-package.cl [deleted file]
uffi/clsql-uffi-package.lisp [new file with mode: 0644]
uffi/clsql-uffi.cl [deleted file]
uffi/clsql-uffi.lisp [new file with mode: 0644]

index 8f3a961..a996f85 100644 (file)
@@ -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")
-
index 9ac0fde..dcb0e28 100644 (file)
@@ -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
 ;;;;
             (: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))))
index 975c588..8b440c1 100644 (file)
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg\r
 ;;;; Date Started:  Aug 2002\r
 ;;;;\r
-;;;; $Id: clsql-mysql.asd,v 1.10 2002/09/25 12:44:59 kevin Exp $\r
+;;;; $Id: clsql-mysql.asd,v 1.11 2002/09/30 10:19:23 kevin Exp $\r
 ;;;;\r
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg\r
 ;;;;\r
@@ -39,8 +39,3 @@
             (:file "mysql-sql" :depends-on ("mysql-api"))\r
             (:file "mysql-usql" :depends-on ("mysql-sql")))))\r
   :depends-on (:uffi :clsql-base :clsql-uffi))\r
-   \r
-#+(or allegro lispworks cmu openmcl mcl)\r
-(defmethod source-file-type  ((c cl-source-file)\r
-                             (s (eql (find-system :clsql-mysql)))) \r
-   "cl")\r
index e8b9f98..56707a0 100644 (file)
@@ -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)
 
               (: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")
-
-
-
index 5cc71c8..4504817 100644 (file)
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg\r
 ;;;; Date Started:  Aug 2002\r
 ;;;;\r
-;;;; $Id: clsql-postgresql-socket.asd,v 1.10 2002/09/25 12:44:59 kevin Exp $\r
+;;;; $Id: clsql-postgresql-socket.asd,v 1.11 2002/09/30 10:19:23 kevin Exp $\r
 ;;;;\r
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg\r
 ;;;;\r
@@ -39,9 +39,3 @@
             (:file "postgresql-socket-sql"\r
                    :depends-on ("postgresql-socket-api")))))\r
   :depends-on (:clsql-base :uffi))\r
-\r
-#+(or allegro lispworks cmu openmcl mcl)\r
-(defmethod source-file-type  ((c cl-source-file)\r
-                             (s (eql (find-system :clsql-postgresql-socket)))) \r
-   "cl")\r
-\r
index fb61b84..f377ddd 100644 (file)
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg\r
 ;;;; Date Started:  Aug 2002\r
 ;;;;\r
-;;;; $Id: clsql-postgresql.asd,v 1.10 2002/09/25 12:44:59 kevin Exp $\r
+;;;; $Id: clsql-postgresql.asd,v 1.11 2002/09/30 10:19:23 kevin Exp $\r
 ;;;;\r
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg\r
 ;;;;\r
@@ -38,8 +38,3 @@
             (:file "postgresql-sql" :depends-on ("postgresql-api"))\r
             (:file "postgresql-usql" :depends-on ("postgresql-sql")))))\r
   :depends-on (:uffi :clsql-base :clsql-uffi))\r
-\r
-#+(or allegro lispworks cmu openmcl mcl)\r
-(defmethod source-file-type  ((c cl-source-file)\r
-                             (s (eql (find-system :clsql-postgresql)))) \r
-   "cl")\r
index 8c6918b..e5e726d 100644 (file)
@@ -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")
index 0c7c27d..f4a609d 100644 (file)
--- 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
 ;;;;
   :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 (file)
index f00e0f2..0000000
+++ /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 (file)
index 0000000..413ba7b
--- /dev/null
@@ -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 (file)
index b4b5403..0000000
+++ /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 (file)
index 0000000..641764b
--- /dev/null
@@ -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 (file)
index b58c8b0..0000000
+++ /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 (file)
index 0000000..6842f8b
--- /dev/null
@@ -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 (file)
index 14c9d9f..0000000
+++ /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 (file)
index 0000000..b0c9c14
--- /dev/null
@@ -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 (file)
index fcb3623..0000000
+++ /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 (file)
index 0000000..95499be
--- /dev/null
@@ -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 (file)
index 4d7102a..0000000
+++ /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 (file)
index 0000000..472d810
--- /dev/null
@@ -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 (file)
index 0b56732..0000000
+++ /dev/null
@@ -1,105 +0,0 @@
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-\r
-;;;; *************************************************************************\r
-;;;; FILE IDENTIFICATION\r
-;;;;\r
-;;;; Name:          mysql-usql.cl\r
-;;;; Purpose:       MySQL interface functions to support UncommonSQL\r
-;;;; Programmers:   Kevin M. Rosenberg and onShore Development Inc\r
-;;;; Date Started:  Mar 2002\r
-;;;;\r
-;;;; $Id: mysql-usql.cl,v 1.1 2002/09/18 07:43:40 kevin Exp $\r
-;;;;\r
-;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg\r
-;;;; and by onShore Development Inc.\r
-;;;;\r
-;;;; CLSQL users are granted the rights to distribute and use this software\r
-;;;; as governed by the terms of the Lisp Lesser GNU Public License\r
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.\r
-;;;; *************************************************************************\r
-\r
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))\r
-(in-package :clsql-mysql)\r
-\r
-;; Table and attribute introspection\r
-\r
-(defmethod database-list-tables ((database mysql-database)\r
-                                &key (system-tables nil))\r
-  (declare (ignore system-tables))\r
-  (mapcar #'car (database-query "show tables" database :auto)))\r
-    \r
-\r
-(defmethod database-list-attributes ((table string) (database mysql-database))\r
-  (mapcar #'car\r
-         (database-query\r
-          (format nil "SHOW COLUMNS FROM ~A" table)\r
-          database nil)))\r
-\r
-(defmethod database-attribute-type (attribute (table string)\r
-                                   (database mysql-database))\r
-  (let ((result\r
-         (mapcar #'cadr\r
-                 (database-query\r
-                  (format nil\r
-                          "SHOW COLUMNS FROM ~A LIKE '~A'" table attribute)\r
-                  database nil))))\r
-    (let* ((str (car result))\r
-          (end-str (position #\( str))\r
-          (substr (subseq str 0 end-str)))\r
-      (if substr\r
-      (intern (string-upcase substr) :keyword) nil))))\r
-\r
-;;; Sequence functions\r
-\r
-(defun %sequence-name-to-table (sequence-name)\r
-  (concatenate 'string "_usql_seq_" (sql-escape sequence-name)))\r
-\r
-(defmethod database-create-sequence (sequence-name\r
-                                    (database mysql-database))\r
-  (let ((table-name (%sequence-name-to-table sequence-name)))\r
-    (database-execute-command\r
-     (concatenate 'string "CREATE TABLE " table-name\r
-                 " (id int NOT NULL PRIMARY KEY AUTO_INCREMENT)")\r
-     database)\r
-    (database-execute-command \r
-     (concatenate 'string "INSERT INTO " table-name\r
-                 " VALUES (0)")\r
-     database)))\r
-\r
-(defmethod database-drop-sequence (sequence-name\r
-                                  (database mysql-database))\r
-  (database-execute-command\r
-   (concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name)) \r
-   database))\r
-\r
-(defmethod database-sequence-next (sequence-name (database mysql-database))\r
-  (database-execute-command \r
-   (concatenate 'string "UPDATE " (%sequence-name-to-table sequence-name)\r
-               " SET id=LAST_INSERT_ID(id+1)")\r
-   database)\r
-  (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database)))\r
-\r
-;; Misc USQL functions\r
-\r
-#|\r
-#+ignore\r
-(defmethod database-output-sql ((expr clsql-sys::sql-typecast-exp) \r
-                               (database mysql-database))\r
-  (with-slots (clsql-sys::modifier clsql-sys::components)\r
-    expr\r
-    (if clsql-sys::modifier\r
-        (progn\r
-          (clsql-sys::output-sql clsql-sys::components database)\r
-          (write-char #\: sql-sys::*sql-stream*)\r
-          (write-char #\: sql-sys::*sql-stream*)\r
-          (write-string (symbol-name clsql-sys::modifier) \r
-                       clsql-sys::*sql-stream*)))))\r
-\r
-#+ignore\r
-(defmethod database-output-sql-as-type ((type (eql 'integer)) val\r
-                                       (database mysql-database))\r
-  ;; typecast it so it uses the indexes\r
-  (when val\r
-    (make-instance 'clsql-sys::sql-typecast-exp\r
-                   :modifier 'int8\r
-                   :components val)))\r
-|#\r
diff --git a/db-mysql/mysql-usql.lisp b/db-mysql/mysql-usql.lisp
new file mode 100644 (file)
index 0000000..dc3ea83
--- /dev/null
@@ -0,0 +1,105 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-\r
+;;;; *************************************************************************\r
+;;;; FILE IDENTIFICATION\r
+;;;;\r
+;;;; Name:          mysql-usql.cl\r
+;;;; Purpose:       MySQL interface functions to support UncommonSQL\r
+;;;; Programmers:   Kevin M. Rosenberg and onShore Development Inc\r
+;;;; Date Started:  Mar 2002\r
+;;;;\r
+;;;; $Id: mysql-usql.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $\r
+;;;;\r
+;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg\r
+;;;; and by onShore Development Inc.\r
+;;;;\r
+;;;; CLSQL users are granted the rights to distribute and use this software\r
+;;;; as governed by the terms of the Lisp Lesser GNU Public License\r
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.\r
+;;;; *************************************************************************\r
+\r
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))\r
+(in-package :clsql-mysql)\r
+\r
+;; Table and attribute introspection\r
+\r
+(defmethod database-list-tables ((database mysql-database)\r
+                                &key (system-tables nil))\r
+  (declare (ignore system-tables))\r
+  (mapcar #'car (database-query "show tables" database :auto)))\r
+    \r
+\r
+(defmethod database-list-attributes ((table string) (database mysql-database))\r
+  (mapcar #'car\r
+         (database-query\r
+          (format nil "SHOW COLUMNS FROM ~A" table)\r
+          database nil)))\r
+\r
+(defmethod database-attribute-type (attribute (table string)\r
+                                   (database mysql-database))\r
+  (let ((result\r
+         (mapcar #'cadr\r
+                 (database-query\r
+                  (format nil\r
+                          "SHOW COLUMNS FROM ~A LIKE '~A'" table attribute)\r
+                  database nil))))\r
+    (let* ((str (car result))\r
+          (end-str (position #\( str))\r
+          (substr (subseq str 0 end-str)))\r
+      (if substr\r
+      (intern (string-upcase substr) :keyword) nil))))\r
+\r
+;;; Sequence functions\r
+\r
+(defun %sequence-name-to-table (sequence-name)\r
+  (concatenate 'string "_usql_seq_" (sql-escape sequence-name)))\r
+\r
+(defmethod database-create-sequence (sequence-name\r
+                                    (database mysql-database))\r
+  (let ((table-name (%sequence-name-to-table sequence-name)))\r
+    (database-execute-command\r
+     (concatenate 'string "CREATE TABLE " table-name\r
+                 " (id int NOT NULL PRIMARY KEY AUTO_INCREMENT)")\r
+     database)\r
+    (database-execute-command \r
+     (concatenate 'string "INSERT INTO " table-name\r
+                 " VALUES (0)")\r
+     database)))\r
+\r
+(defmethod database-drop-sequence (sequence-name\r
+                                  (database mysql-database))\r
+  (database-execute-command\r
+   (concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name)) \r
+   database))\r
+\r
+(defmethod database-sequence-next (sequence-name (database mysql-database))\r
+  (database-execute-command \r
+   (concatenate 'string "UPDATE " (%sequence-name-to-table sequence-name)\r
+               " SET id=LAST_INSERT_ID(id+1)")\r
+   database)\r
+  (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database)))\r
+\r
+;; Misc USQL functions\r
+\r
+#|\r
+#+ignore\r
+(defmethod database-output-sql ((expr clsql-sys::sql-typecast-exp) \r
+                               (database mysql-database))\r
+  (with-slots (clsql-sys::modifier clsql-sys::components)\r
+    expr\r
+    (if clsql-sys::modifier\r
+        (progn\r
+          (clsql-sys::output-sql clsql-sys::components database)\r
+          (write-char #\: sql-sys::*sql-stream*)\r
+          (write-char #\: sql-sys::*sql-stream*)\r
+          (write-string (symbol-name clsql-sys::modifier) \r
+                       clsql-sys::*sql-stream*)))))\r
+\r
+#+ignore\r
+(defmethod database-output-sql-as-type ((type (eql 'integer)) val\r
+                                       (database mysql-database))\r
+  ;; typecast it so it uses the indexes\r
+  (when val\r
+    (make-instance 'clsql-sys::sql-typecast-exp\r
+                   :modifier 'int8\r
+                   :components val)))\r
+|#\r
diff --git a/db-mysql/testing/mysql-struct-size.cl b/db-mysql/testing/mysql-struct-size.cl
deleted file mode 100644 (file)
index 60dfd92..0000000
+++ /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 (file)
index 0000000..60dfd92
--- /dev/null
@@ -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 (file)
index 6848762..0000000
+++ /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 (file)
index 0000000..97dafb6
--- /dev/null
@@ -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 (file)
index 245a2b4..0000000
+++ /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 (file)
index 0000000..a7c3cfa
--- /dev/null
@@ -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 (file)
index d35c5cc..0000000
+++ /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 (file)
index 0000000..b7f3b84
--- /dev/null
@@ -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 (file)
index 23f22d7..0000000
+++ /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 (file)
index 0000000..23f22d7
--- /dev/null
@@ -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 (file)
index ef25caf..0000000
+++ /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 (file)
index 0000000..2d78a05
--- /dev/null
@@ -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 (file)
index 76fdad6..0000000
+++ /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 (file)
index 0000000..072465e
--- /dev/null
@@ -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 (file)
index bde69eb..0000000
+++ /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 (file)
index 0000000..1e0ed79
--- /dev/null
@@ -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 (file)
index 8a580b7..0000000
+++ /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 "~@<Asynchronous notification on connection ~A: ~:@_~A~:@>"
-            (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 (file)
index 0000000..afd0014
--- /dev/null
@@ -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 "~@<Asynchronous notification on connection ~A: ~:@_~A~:@>"
+            (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