db-postgresql-socket3/sql.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:     postgresql-socket-sql.sql
   6 ;;;; Purpose:  High-level PostgreSQL interface using socket
   7 ;;;; Authors:  Kevin M. Rosenberg based on original code by Pierre R. Mai
   8 ;;;; Created:  Feb 2002
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of CLSQL, is Copyright (c) 2002-2007 by Kevin M. Rosenberg
  13 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
  14 ;;;;
  15 ;;;; CLSQL users are granted the rights to distribute and use this software
  16 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  17 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  18 ;;;; *************************************************************************
  19
  20 (in-package #:cl-user)
  21
  22 (defpackage :clsql-postgresql-socket3
  23     (:use #:common-lisp #:clsql-sys #:postgresql-socket)
  24     (:export #:postgresql-socket-database)
  25     (:documentation "This is the CLSQL socket interface to PostgreSQL."))
  26
  27 (in-package #:clsql-postgresql-socket3)
  28
  29 ;; interface foreign library loading routines
  30
  31 (clsql-sys:database-type-load-foreign :postgresql-socket3)
  32
  33
  34 (defmethod database-initialize-database-type ((database-type
  35                                                (eql :postgresql-socket3)))
  36   t)
  37
  38
  39 ;; Field type conversion
  40 (defun convert-to-clsql-warning (database condition)
  41   (ecase *backend-warning-behavior*
  42     (:warn
  43      (warn 'sql-database-warning :database database
  44            :message (postgresql-condition-message condition)))
  45     (:error
  46      (error 'sql-database-error :database database
  47             :message (format nil "Warning upgraded to error: ~A"
  48                              (postgresql-condition-message condition))))
  49     ((:ignore nil)
  50      ;; do nothing
  51      )))
  52
  53 (defun convert-to-clsql-error (database expression condition)
  54   (error 'sql-database-data-error
  55          :database database
  56          :expression expression
  57          :error-id (type-of condition)
  58          :message (postgresql-condition-message condition)))
  59
  60 (defmacro with-postgresql-handlers
  61     ((database &optional expression)
  62      &body body)
  63   (let ((database-var (gensym))
  64         (expression-var (gensym)))
  65     `(let ((,database-var ,database)
  66            (,expression-var ,expression))
  67        (handler-bind ((postgresql-warning
  68                        (lambda (c)
  69                          (convert-to-clsql-warning ,database-var c)))
  70                       (postgresql-error
  71                        (lambda (c)
  72                          (convert-to-clsql-error
  73                           ,database-var ,expression-var c))))
  74          ,@body))))
  75
  76
  77
  78 (defclass postgresql-socket3-database (generic-postgresql-database)
  79   ((connection :accessor database-connection :initarg :connection
  80                :type cl-postgres:database-connection)))
  81
  82 (defmethod database-type ((database postgresql-socket3-database))
  83   :postgresql-socket3)
  84
  85 (defmethod database-name-from-spec (connection-spec (database-type (eql :postgresql-socket3)))
  86   (check-connection-spec connection-spec database-type
  87                          (host db user password &optional port options tty))
  88   (destructuring-bind (host db user password &optional port options tty)
  89       connection-spec
  90     (declare (ignore password options tty))
  91     (concatenate 'string
  92       (etypecase host
  93         (null
  94          "localhost")
  95         (pathname (namestring host))
  96         (string host))
  97       (when port
  98         (concatenate 'string
  99                      ":"
 100                      (etypecase port
 101                        (integer (write-to-string port))
 102                        (string port))))
 103       "/" db "/" user)))
 104
 105 (defmethod database-connect (connection-spec
 106                              (database-type (eql :postgresql-socket)))
 107   (check-connection-spec connection-spec database-type
 108                          (host db user password &optional port options tty))
 109   (destructuring-bind (host db user password &optional
 110                             (port +postgresql-server-default-port+)
 111                             (options "") (tty ""))
 112       connection-spec
 113     (handler-case
 114         (handler-bind ((warning
 115                         (lambda (c)
 116                           (warn 'sql-warning
 117                                 :format-control "~A"
 118                                 :format-arguments
 119                                 (list (princ-to-string c))))))
 120           (cl-postgres:open-database
 121            :database db
 122            :user user
 123            :password password
 124            :host host
 125            :port port
 126            ))
 127       (cl-postgres:database-error (c)
 128         ;; Connect failed
 129         (error 'sql-connection-error
 130                :database-type database-type
 131                :connection-spec connection-spec
 132                :error-id (type-of c)
 133                :message (postgresql-condition-message c)))
 134       (:no-error (connection)
 135                  ;; Success, make instance
 136                  (make-instance 'postgresql-socket3-database
 137                                 :name (database-name-from-spec connection-spec database-type)
 138                                 :database-type :postgresql-socket3
 139                                 :connection-spec connection-spec
 140                                 :connection connection)))))
 141
 142 (defmethod database-disconnect ((database postgresql-socket3-database))
 143   (cl-postgres:close-database (database-connection database))
 144   t)
 145
 146 (defvar *include-field-names* nil)
 147
 148 (cl-postgres:def-row-reader clsql-default-row-reader (fields)
 149   (values (loop :while (next-row)
 150                 :collect (loop :for field :across fields
 151                                :collect (next-field field)))
 152           (when *include-field-names*
 153             (loop :for field :across fields
 154                   :collect (field-name field)))))
 155
 156 (defmethod database-query ((expression string) (database postgresql-socket3-database) result-types field-names)
 157   (let ((connection (database-connection database)))
 158     (with-postgresql-handlers (database expression)
 159       (let ((*include-field-names* field-names))
 160         (cl-postgres:exec-query connection expression #'clsql-default-row-reader))
 161       )))
 162
 163 (defmethod database-execute-command
 164     ((expression string) (database postgresql-socket3-database))
 165   (let ((connection (database-connection database)))
 166     (with-postgresql-handlers (database expression)
 167       (exec-query connection expression))))
 168
 169 ;;;; Cursoring interface
 170
 171 (defclass cursor ()
 172   ((next-row :accessor next-row :initarg :next-row :initform nil)
 173    (fields :accessor fields :initarg :fields :initform nil)
 174    (next-field :accessor next-field :initarg :next-field :initform nil)
 175    (done :accessor done :initarg :done :initform nil)))
 176
 177 (defvar *cursor* ())
 178
 179 (cl-postgres:def-row-reader clsql-cursored-row-reader (fields)
 180   (setf *cursor*
 181         (make-instance 'cursor :next-row #'next-row :fields fields :next-field #'next-field)))
 182
 183 (defmethod database-query-result-set ((expression string)
 184                                       (database postgresql-socket3-database)
 185                                       &key full-set result-types)
 186   (declare (ignore full-set))
 187   (let ((connection (database-connection database))
 188         *cursor*)
 189     (with-postgresql-handlers (database expression)
 190       (cl-postgres:exec-query connection expression 'clsql-cursored-row-reader)
 191       (values *cursor* (length (fields *cursor*))))))
 192
 193 (defmethod database-dump-result-set (result-set
 194                                      (database postgresql-socket-database))
 195   (unless (done result-set)
 196     (loop :while (funcall (next-row result-set))))
 197   T)
 198
 199 (defmethod database-store-next-row (result-set
 200                                     (database postgresql-socket-database)
 201                                     list)
 202   (when (and (not (done result-set))
 203              (setf (done result-set) (funcall (next-row result-set))))
 204
 205     (let* ((data (loop :for field :across (fields result-set)
 206                        :collect (funcall (next-field result-set) field))))
 207       ;; Maybe?
 208       (setf (car list) (car data)
 209             (cdr list) (cdr data)))))
 210
 211
 212 ;;;;;;;;;;;;;;;;;;;;;;;;;;
 213
 214
 215 (defmethod database-create (connection-spec (type (eql :postgresql-socket3)))
 216   (destructuring-bind (host name user password &optional port options tty) connection-spec
 217     (let ((database (database-connect (list host "postgres" user password)
 218                                       type)))
 219       (setf (slot-value database 'clsql-sys::state) :open)
 220       (unwind-protect
 221            (database-execute-command (format nil "create database ~A" name) database)
 222         (database-disconnect database)))))
 223
 224 (defmethod database-destroy (connection-spec (type (eql :postgresql-socket3)))
 225   (destructuring-bind (host name user password &optional port optional tty) connection-spec
 226     (let ((database (database-connect (list host "postgres" user password)
 227                                       type)))
 228       (setf (slot-value database 'clsql-sys::state) :open)
 229       (unwind-protect
 230           (database-execute-command (format nil "drop database ~A" name) database)
 231         (database-disconnect database)))))
 232
 233
 234 (defmethod database-probe (connection-spec (type (eql :postgresql-socket3)))
 235   (when (find (second connection-spec) (database-list connection-spec type)
 236               :test #'string-equal)
 237     t))
 238
 239
 240 ;; Database capabilities
 241
 242 (defmethod db-backend-has-create/destroy-db? ((db-type (eql :postgresql-socket3)))
 243   nil)
 244
 245 (defmethod db-type-has-fancy-math? ((db-type (eql :postgresql-socket3)))
 246   t)
 247
 248 (defmethod db-type-default-case ((db-type (eql :postgresql-socket3)))
 249   :lower)
 250
 251 (defmethod database-underlying-type ((database postgresql-socket3-database))
 252   :postgresql)
 253
 254 (when (clsql-sys:database-type-library-loaded :postgresql-socket3)
 255   (clsql-sys:initialize-database-type :database-type :postgresql-socket3))