From 6e49d313475d42d2ef7b4eea626f2d7da902d09e Mon Sep 17 00:00:00 2001 From: Russ Tyndall Date: Wed, 8 Jun 2011 16:39:17 -0400 Subject: [PATCH] cl-postgres-socket3 backend using cl-postgres (backing of postmodern) Major goals * Use newer version (3) of the postgres socket api * Allows use of command objects and prepared statements against postgres. --- clsql-postgresql-socket3.asd | 39 +++ db-postgresql-socket3/.gitignore | 14 + db-postgresql-socket3/api.lisp | 64 +++++ db-postgresql-socket3/command-object.lisp | 37 +++ db-postgresql-socket3/package.lisp | 35 +++ db-postgresql-socket3/sql.lisp | 333 ++++++++++++++++++++++ sql/fddl.lisp | 12 +- tests/test-init.lisp | 16 ++ tests/utils.lisp | 3 +- 9 files changed, 548 insertions(+), 5 deletions(-) create mode 100644 clsql-postgresql-socket3.asd create mode 100644 db-postgresql-socket3/.gitignore create mode 100644 db-postgresql-socket3/api.lisp create mode 100644 db-postgresql-socket3/command-object.lisp create mode 100644 db-postgresql-socket3/package.lisp create mode 100644 db-postgresql-socket3/sql.lisp diff --git a/clsql-postgresql-socket3.asd b/clsql-postgresql-socket3.asd new file mode 100644 index 0000000..901057a --- /dev/null +++ b/clsql-postgresql-socket3.asd @@ -0,0 +1,39 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql-postgresql-socket.asd +;;;; Purpose: ASDF file for CLSQL PostgresSQL socket (protocol vs 3) backend +;;;; Programmer: Russ Tyndall +;;;; Date Started: Sept 2009 +;;;; +;;;; $Id$ +;;;; +;;;; 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. +;;;; ************************************************************************* + +(defpackage #:clsql-postgresql-socket-system (:use #:asdf #:cl)) +(in-package #:clsql-postgresql-socket-system) + +;;; System definition + +(defsystem clsql-postgresql-socket3 + :name "cl-sql-postgresql-socket3" + :author "Russ Tyndall " + :maintainer "Russ Tyndall " + :licence "Lessor Lisp General Public License" + :description "Common Lisp SQL PostgreSQL Socket Driver" + :long-description "cl-sql-postgresql-socket package provides a database driver to the PostgreSQL database via a socket interface." + + :depends-on (clsql md5 :cl-postgres #+sbcl sb-bsd-sockets) + :components + ((:module :db-postgresql-socket3 + :serial T + :components ((:file "command-object") + (:file "package") + (:file "api") + (:file "sql"))))) diff --git a/db-postgresql-socket3/.gitignore b/db-postgresql-socket3/.gitignore new file mode 100644 index 0000000..1d27afc --- /dev/null +++ b/db-postgresql-socket3/.gitignore @@ -0,0 +1,14 @@ +clsql-uffi.so +clsql-uffi.dll +clsql-uffi.lib +clsql-uffi.dylib +.bin +*.fasl +*.pfsl +*.dfsl +*.cfsl +*.fasla16 +*.fasla8 +*.faslm16 +*.faslm8 +*.fsl diff --git a/db-postgresql-socket3/api.lisp b/db-postgresql-socket3/api.lisp new file mode 100644 index 0000000..ad6ca18 --- /dev/null +++ b/db-postgresql-socket3/api.lisp @@ -0,0 +1,64 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: postgresql-socket-api.lisp +;;;; Purpose: Low-level PostgreSQL interface using sockets +;;;; Authors: Kevin M. Rosenberg based on original code by Pierre R. Mai +;;;; Created: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 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. +;;;; ************************************************************************* + +(in-package #:postgresql-socket3) + +(defmethod clsql-sys:database-type-load-foreign ((database-type (eql :postgresql-socket3))) + t) + +(defmethod clsql-sys:database-type-library-loaded ((database-type + (eql :postgresql-socket3))) + "T if foreign library was able to be loaded successfully. Always true for +socket interface" + t) + +(defparameter +postgresql-server-default-port+ 5432 + "Default port of PostgreSQL server.") + +;;;; Condition hierarchy + +(define-condition postgresql-condition (condition) + ((connection :initarg :connection :reader postgresql-condition-connection) + (message :initarg :message :reader postgresql-condition-message)) + (:report + (lambda (c stream) + (format stream "~@<~A occurred on connection ~A. ~:@_Reason: ~A~:@>" + (type-of c) + (postgresql-condition-connection c) + (postgresql-condition-message c))))) + +(define-condition postgresql-error (error postgresql-condition) + ()) + +(define-condition postgresql-fatal-error (postgresql-error) + ()) + +(define-condition postgresql-login-error (postgresql-fatal-error) + ()) + +(define-condition postgresql-warning (warning postgresql-condition) + ()) + +(define-condition postgresql-notification (postgresql-condition) + () + (:report + (lambda (c stream) + (format stream "~@" + (postgresql-condition-connection c) + (postgresql-condition-message c))))) \ No newline at end of file diff --git a/db-postgresql-socket3/command-object.lisp b/db-postgresql-socket3/command-object.lisp new file mode 100644 index 0000000..47dad33 --- /dev/null +++ b/db-postgresql-socket3/command-object.lisp @@ -0,0 +1,37 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: postgresql-socket-sql.sql +;;;; Purpose: High-level PostgreSQL interface using socket +;;;; Authors: Russ Tyndall (at Acceleration.net) based on original code by +;;;; Kevin M. Rosenberg based on original code by Pierre R. Mai +;;;; Created: Sep 2009 +;;;; +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2007 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. +;;;; +;;;; ************************************************************************* + +(in-package #:clsql-sys) + +(defclass command-object () + ((expression :accessor expression :initarg :expression :initform nil) + (parameters :accessor parameters :initarg :parameters :initform nil) + (prepared-name :accessor prepared-name :initarg :prepared-name :initform "" + :documentation "If we want this to be a prepared statement, give it a name + to identify it to this session") + (has-been-prepared :accessor has-been-prepared :initarg :has-been-prepared :initform nil + :documentation "Have we already prepared this command object") + )) + +(export '(expression parameters prepared-name has-been-prepared command-object)) + + diff --git a/db-postgresql-socket3/package.lisp b/db-postgresql-socket3/package.lisp new file mode 100644 index 0000000..430b2eb --- /dev/null +++ b/db-postgresql-socket3/package.lisp @@ -0,0 +1,35 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: postgresql-socket-package.lisp +;;;; Purpose: Package definition for PostgreSQL interface using sockets +;;;; Programmers: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; 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. +;;;; ************************************************************************* + +(in-package #:cl-user) + +#+lispworks (require "comm") + +(defpackage #:postgresql-socket3 + (:use #:cl md5 #:cl-postgres) + (:shadow #:postgresql-warning) + (:export #:+postgresql-server-default-port+ + #:postgresql-condition + #:postgresql-error + #:postgresql-fatal-error + #:postgresql-login-error + #:postgresql-warning + #:postgresql-notification + #:postgresql-condition-message + #:postgresql-condition-connection)) + diff --git a/db-postgresql-socket3/sql.lisp b/db-postgresql-socket3/sql.lisp new file mode 100644 index 0000000..1f27989 --- /dev/null +++ b/db-postgresql-socket3/sql.lisp @@ -0,0 +1,333 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: postgresql-socket-sql.sql +;;;; Purpose: High-level PostgreSQL interface using socket +;;;; Authors: Kevin M. Rosenberg based on original code by Pierre R. Mai +;;;; Created: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2007 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. +;;;; ************************************************************************* + +(in-package #:cl-user) + +(defpackage :clsql-postgresql-socket3 + (:use #:common-lisp #:clsql-sys #:postgresql-socket3) + (:export #:postgresql-socket3-database) + (:documentation "This is the CLSQL socket interface (protocol version 3) to PostgreSQL.")) + +(in-package #:clsql-postgresql-socket3) + +(defvar *sqlreader* (cl-postgres:copy-sql-readtable)) +(let ((dt-fn (lambda (useconds-since-2000) + (let ((sec (truncate + (/ useconds-since-2000 + 1000000))) + (usec (mod useconds-since-2000 + 1000000))) + (clsql:make-time :year 2000 :second sec :usec usec))))) + (cl-postgres:set-sql-datetime-readers + :table *sqlreader* + :date (lambda (days-since-2000) + (clsql:make-date :year 2000 :day (+ 1 days-since-2000))) + :timestamp dt-fn + :timestamp-with-timezone dt-fn)) + + + +;; interface foreign library loading routines + +(clsql-sys:database-type-load-foreign :postgresql-socket3) + + +(defmethod database-initialize-database-type ((database-type + (eql :postgresql-socket3))) + t) + + +;; Field type conversion +(defun convert-to-clsql-warning (database condition) + (ecase *backend-warning-behavior* + (:warn + (warn 'sql-database-warning :database database + :message (cl-postgres:database-error-message condition))) + (:error + (error 'sql-database-error :database database + :message (format nil "Warning upgraded to error: ~A" + (cl-postgres:database-error-message condition)))) + ((:ignore nil) + ;; do nothing + ))) + +(defun convert-to-clsql-error (database expression condition) + (error 'sql-database-data-error + :database database + :expression expression + :error-id (type-of condition) + :message (cl-postgres:database-error-message condition))) + +(defmacro with-postgresql-handlers + ((database &optional expression) + &body body) + (let ((database-var (gensym)) + (expression-var (gensym))) + `(let ((,database-var ,database) + (,expression-var ,expression)) + (handler-bind ((postgresql-warning + (lambda (c) + (convert-to-clsql-warning ,database-var c))) + (cl-postgres:database-error + (lambda (c) + (convert-to-clsql-error + ,database-var ,expression-var c)))) + ,@body)))) + + + +(defclass postgresql-socket3-database (generic-postgresql-database) + ((connection :accessor database-connection :initarg :connection + :type cl-postgres:database-connection))) + +(defmethod database-type ((database postgresql-socket3-database)) + :postgresql-socket3) + +(defmethod database-name-from-spec (connection-spec (database-type (eql :postgresql-socket3))) + (check-connection-spec connection-spec database-type + (host db user password &optional port options tty)) + (destructuring-bind (host db user password &optional port options tty) + connection-spec + (declare (ignore password options tty)) + (concatenate 'string + (etypecase host + (null + "localhost") + (pathname (namestring host)) + (string host)) + (when port + (concatenate 'string + ":" + (etypecase port + (integer (write-to-string port)) + (string port)))) + "/" db "/" user))) + +(defmethod database-connect (connection-spec + (database-type (eql :postgresql-socket3))) + (check-connection-spec connection-spec database-type + (host db user password &optional port options tty)) + (destructuring-bind (host db user password &optional + (port +postgresql-server-default-port+) + (options "") (tty "")) + connection-spec + (declare (ignore options tty)) + (handler-case + (handler-bind ((warning + (lambda (c) + (warn 'sql-warning + :format-control "~A" + :format-arguments + (list (princ-to-string c)))))) + (cl-postgres:open-database db user password host port)) + (cl-postgres:database-error (c) + ;; Connect failed + (error 'sql-connection-error + :database-type database-type + :connection-spec connection-spec + :error-id (type-of c) + :message (cl-postgres:database-error-message c))) + (:no-error (connection) + ;; Success, make instance + (make-instance 'postgresql-socket3-database + :name (database-name-from-spec connection-spec database-type) + :database-type :postgresql-socket3 + :connection-spec connection-spec + :connection connection))))) + +(defmethod database-disconnect ((database postgresql-socket3-database)) + (cl-postgres:close-database (database-connection database)) + t) + +(defvar *include-field-names* nil) + + +;; THE FOLLOWING MACRO EXPANDS TO THE FUNCTION BELOW IT, +;; BUT TO GET null CONVENTIONS CORRECT I NEEDED TO TWEAK THE EXPANSION +;; +;; (cl-postgres:def-row-reader clsql-default-row-reader (fields) +;; (values (loop :while (cl-postgres:next-row) +;; :collect (loop :for field :across fields +;; :collect (cl-postgres:next-field field))) +;; (when *include-field-names* +;; (loop :for field :across fields +;; :collect (cl-postgres:field-name field))))) + + + +(defun clsql-default-row-reader (stream fields) + (declare (type stream stream) + (type (simple-array cl-postgres::field-description) fields)) + (flet ((cl-postgres:next-row () + (cl-postgres::look-for-row stream)) + (cl-postgres:next-field (cl-postgres::field) + (declare (type cl-postgres::field-description cl-postgres::field)) + (let ((cl-postgres::size (cl-postgres::read-int4 stream))) + (declare (type (signed-byte 32) cl-postgres::size)) + (if (eq cl-postgres::size -1) + nil + (funcall (cl-postgres::field-interpreter cl-postgres::field) + stream cl-postgres::size))))) + (let ((results (loop :while (cl-postgres:next-row) + :collect (loop :for field :across fields + :collect (cl-postgres:next-field field)))) + (col-names (when *include-field-names* + (loop :for field :across fields + :collect (cl-postgres:field-name field))))) + ;;multiple return values were not working here + (list results col-names)))) + +(defmethod database-query ((expression string) (database postgresql-socket3-database) result-types field-names) + (let ((connection (database-connection database)) + (cl-postgres:*sql-readtable* *sqlreader*)) + (with-postgresql-handlers (database expression) + (let ((*include-field-names* field-names)) + (apply #'values (cl-postgres:exec-query connection expression #'clsql-default-row-reader))) + ))) + +(defmethod query ((obj command-object) &key (database *default-database*) + (result-types :auto) (flatp nil) (field-names t)) + (clsql-sys::record-sql-command (expression obj) database) + (multiple-value-bind (rows names) + (database-query obj database result-types field-names) + (let ((result (if (and flatp (= 1 (length (car rows)))) + (mapcar #'car rows) + rows))) + (clsql-sys::record-sql-result result database) + (if field-names + (values result names) + result)))) + +(defmethod database-query ((obj command-object) (database postgresql-socket3-database) result-types field-names) + (let ((connection (database-connection database)) + (cl-postgres:*sql-readtable* *sqlreader*)) + (with-postgresql-handlers (database obj) + (let ((*include-field-names* field-names)) + (unless (has-been-prepared obj) + (cl-postgres:prepare-query connection (prepared-name obj) (expression obj)) + (setf (has-been-prepared obj) T)) + (apply #'values (cl-postgres:exec-prepared + connection + (prepared-name obj) + (parameters obj) + #'clsql-default-row-reader)))))) + +(defmethod database-execute-command + ((expression string) (database postgresql-socket3-database)) + (let ((connection (database-connection database))) + (with-postgresql-handlers (database expression) + ;; return row count? + (second (multiple-value-list (cl-postgres:exec-query connection expression)))))) + +(defmethod execute-command ((obj command-object) + &key (database *default-database*)) + (clsql-sys::record-sql-command (expression obj) database) + (let ((res (database-execute-command obj database))) + (clsql-sys::record-sql-result res database) + ;; return row count? + res)) + +(defmethod database-execute-command + ((obj command-object) (database postgresql-socket3-database)) + (let ((connection (database-connection database))) + (with-postgresql-handlers (database obj) + (unless (has-been-prepared obj) + (cl-postgres:prepare-query connection (prepared-name obj) (expression obj)) + (setf (has-been-prepared obj) T)) + (second (multiple-value-list (cl-postgres:exec-prepared connection (prepared-name obj) (parameters obj))))))) + +;;;; Cursoring interface + + +(defmethod database-query-result-set ((expression string) + (database postgresql-socket3-database) + &key full-set result-types) + (declare (ignore result-types)) + (declare (ignore full-set)) + (error "Cursoring interface is not supported for postgresql-socket3-database try cl-postgres:exec-query with a custom row-reader")) + +(defmethod database-dump-result-set (result-set + (database postgresql-socket3-database)) + (error "Cursoring interface is not supported for postgresql-socket3-database try cl-postgres:exec-query with a custom row-reader") + T) + +(defmethod database-store-next-row (result-set + (database postgresql-socket3-database) + list) + (error "Cursoring interface is not supported for postgresql-socket3-database try cl-postgres:exec-query with a custom row-reader")) + + +;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defmethod database-create (connection-spec (type (eql :postgresql-socket3))) + (destructuring-bind (host name user password &optional port options tty) connection-spec + (declare (ignore port options tty)) + (let ((database (database-connect (list host "postgres" user password) + type))) + (setf (slot-value database 'clsql-sys::state) :open) + (unwind-protect + (database-execute-command (format nil "create database ~A" name) database) + (database-disconnect database))))) + +(defmethod database-destroy (connection-spec (type (eql :postgresql-socket3))) + (destructuring-bind (host name user password &optional port options tty) connection-spec + (declare (ignore port options tty)) + (let ((database (database-connect (list host "postgres" user password) + type))) + (setf (slot-value database 'clsql-sys::state) :open) + (unwind-protect + (database-execute-command (format nil "drop database ~A" name) database) + (database-disconnect database))))) + + +(defmethod database-probe (connection-spec (type (eql :postgresql-socket3))) + (when (find (second connection-spec) (database-list connection-spec type) + :test #'string-equal) + t)) + + +;; Database capabilities + +(defmethod db-backend-has-create/destroy-db? ((db-type (eql :postgresql-socket3))) + nil) + +(defmethod db-type-has-fancy-math? ((db-type (eql :postgresql-socket3))) + t) + +(defmethod db-type-default-case ((db-type (eql :postgresql-socket3))) + :lower) + +(defmethod database-underlying-type ((database postgresql-socket3-database)) + :postgresql) + +(when (clsql-sys:database-type-library-loaded :postgresql-socket3) + (clsql-sys:initialize-database-type :database-type :postgresql-socket3)) + + +;; Type munging functions + +(defmethod read-sql-value (val (type (eql 'boolean)) (database postgresql-socket3-database) db-type) + (declare (ignore database db-type)) + val) + +(defmethod read-sql-value (val (type (eql 'generalized-boolean)) (database postgresql-socket3-database) db-type) + (declare (ignore database db-type)) + val) + diff --git a/sql/fddl.lisp b/sql/fddl.lisp index 19dfea9..2c28ab2 100644 --- a/sql/fddl.lisp +++ b/sql/fddl.lisp @@ -111,6 +111,13 @@ is a string denoting a user name, only tables owned by OWNER are listed. If OWNER is :all then all tables are listed." (database-list-tables database :owner owner)) +(defmethod %table-exists-p (name (database T) &key owner ) + (unless database (setf database *default-database*)) + (let ((name (database-identifier name database)) + (tables (list-tables :owner owner :database database))) + (when (member name tables :test #'string-equal) + t))) + (defun table-exists-p (name &key (owner nil) (database *default-database*)) "Tests for the existence of an SQL table called NAME in DATABASE which defaults to *DEFAULT-DATABASE*. OWNER is nil by default @@ -118,10 +125,7 @@ which means that only tables owned by users are examined. If OWNER is a string denoting a user name, only tables owned by OWNER are examined. If OWNER is :all then all tables are examined." - (when (member (database-identifier name database) - (list-tables :owner owner :database database) - :test #'string-equal) - t)) + (%table-exists-p name database :owner owner)) ;; Views diff --git a/tests/test-init.lisp b/tests/test-init.lisp index 4a83cf9..61fd0a5 100644 --- a/tests/test-init.lisp +++ b/tests/test-init.lisp @@ -311,6 +311,22 @@ :time/pg/fdml/usec :time/pg/oodml/no-usec :time/pg/oodml/usec)) (push (cons test "Postgres specific test.") skip-tests)) + ((and (eql *test-database-type* :postgresql-socket3) + (clsql-sys:in test :BASIC/SELECT/2 :basic/select/3)) + (push (cons test "Postgres-socket3 always auto types") + skip-tests)) + ((and (eql *test-database-type* :postgresql-socket3) + (clsql-sys:in test :fdml/select/18)) + (push (cons test "Postgres-socket3 doesnt support attribute based type coersion") + skip-tests)) + ((and (eql *test-database-type* :postgresql-socket3) + (clsql-sys:in test :basic/map/1 :basic/map/2 :basic/map/3 :basic/map/4 + :basic/do/1 :basic/do/2 :fdml/do-query/1 :fdml/map-query/1 + :fdml/map-query/2 :fdml/map-query/3 :fdml/map-query/4 :fdml/loop/1 + :fdml/loop/2 :fdml/loop/3 + )) + (push (cons test "postgresql-socket3 doesnt support cursoring interface") + skip-tests)) ((and (member *test-database-underlying-type* '(:mysql)) (clsql-sys:in test :time/cross-platform/msec :time/cross-platform/usec/no-tz :time/cross-platform/usec/tz)) diff --git a/tests/utils.lisp b/tests/utils.lisp index ea11786..95c9717 100644 --- a/tests/utils.lisp +++ b/tests/utils.lisp @@ -22,7 +22,7 @@ :type "config")) (defvar +all-db-types+ - '(:postgresql :postgresql-socket :mysql :sqlite :sqlite3 :odbc :oracle + '(:postgresql :postgresql-socket :postgresql-socket3 :mysql :sqlite :sqlite3 :odbc :oracle #+allegro :aodbc)) (defclass conn-specs () @@ -30,6 +30,7 @@ (mysql :accessor mysql-spec :initform nil) (postgresql :accessor postgresql-spec :initform nil) (postgresql-socket :accessor postgresql-socket-spec :initform nil) + (postgresql-socket3 :accessor postgresql-socket3-spec :initform nil) (sqlite :accessor sqlite-spec :initform nil) (sqlite3 :accessor sqlite3-spec :initform nil) (odbc :accessor odbc-spec :initform nil) -- 2.34.1