db-postgresql-socket/postgresql-socket-sql.cl

   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 ;;;; Programmers:   Kevin M. Rosenberg based on
   8 ;;;;                Original code by Pierre R. Mai
   9 ;;;; Date Started:  Feb 2002
  10 ;;;;
  11 ;;;; $Id: postgresql-socket-sql.cl,v 1.2 2002/09/29 18:54:17 kevin Exp $
  12 ;;;;
  13 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
  14 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
  15 ;;;;
  16 ;;;; CLSQL users are granted the rights to distribute and use this software
  17 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  18 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  19 ;;;; *************************************************************************
  20
  21 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
  22 (in-package :cl-user)
  23
  24 (defpackage :clsql-postgresql-socket
  25     (:use :common-lisp :clsql-base-sys :postgresql-socket)
  26     (:export #:postgresql-socket-database)
  27     (:documentation "This is the CLSQL socket interface to PostgreSQL."))
  28
  29 (in-package :clsql-postgresql-socket)
  30
  31 ;; interface foreign library loading routines
  32
  33 (defmethod database-type-library-loaded ((database-type (eql :postgresql-socket)))
  34   t)
  35
  36 (defmethod clsql-base-sys:database-type-load-foreign ((database-type (eql :postgresql-socket)))
  37   t)
  38
  39 (clsql-base-sys:database-type-load-foreign :postgresql-socket)
  40
  41
  42 ;; Field type conversion
  43
  44 (defun make-type-list-for-auto (cursor)
  45   (let* ((fields (postgresql-cursor-fields cursor))
  46          (num-fields (length fields))
  47          (new-types '()))
  48     (dotimes (i num-fields)
  49       (declare (fixnum i))
  50       (push (canonical-field-type fields i) new-types))
  51     (nreverse new-types)))
  52
  53 (defun canonical-field-type (fields index)
  54   "Extracts canonical field type from fields list"
  55   (let ((oid (cadr (nth index fields))))
  56     (case oid
  57       ((#.pgsql-ftype#bytea
  58         #.pgsql-ftype#int2
  59         #.pgsql-ftype#int4)
  60        :int32)
  61       (#.pgsql-ftype#int8
  62        :int64)
  63       ((#.pgsql-ftype#float4
  64         #.pgsql-ftype#float8)
  65        :double)
  66       (otherwise
  67        t))))
  68
  69 (defun canonicalize-types (types cursor)
  70   (if (null types)
  71       nil
  72       (let ((auto-list (make-type-list-for-auto cursor)))
  73         (cond
  74           ((listp types)
  75            (canonicalize-type-list types auto-list))
  76           ((eq types :auto)
  77            auto-list)
  78           (t
  79            nil)))))
  80
  81 (defun canonicalize-type-list (types auto-list)
  82   "Ensure a field type list meets expectations.
  83 Duplicated from clsql-uffi package so that this interface
  84 doesn't depend on UFFI."
  85   (let ((length-types (length types))
  86         (new-types '()))
  87     (loop for i from 0 below (length auto-list)
  88           do
  89           (if (>= i length-types)
  90               (push t new-types) ;; types is shorted than num-fields
  91               (push
  92                (case (nth i types)
  93                  (:int
  94                   (case (nth i auto-list)
  95                     (:int32
  96                      :int32)
  97                     (:int64
  98                      :int64)
  99                     (t
 100                      t)))
 101                  (:double
 102                   (case (nth i auto-list)
 103                     (:double
 104                      :double)
 105                     (t
 106                      t)))
 107                  (t
 108                   t))
 109                new-types)))
 110     (nreverse new-types)))
 111
 112
 113 (defun convert-to-clsql-warning (database condition)
 114   (warn 'clsql-database-warning :database database
 115         :message (postgresql-condition-message condition)))
 116
 117 (defun convert-to-clsql-error (database expression condition)
 118   (error 'clsql-sql-error :database database
 119          :expression expression
 120          :errno (type-of condition)
 121          :error (postgresql-condition-message condition)))
 122
 123 (defmacro with-postgresql-handlers
 124     ((database &optional expression)
 125      &body body)
 126   (let ((database-var (gensym))
 127         (expression-var (gensym)))
 128     `(let ((,database-var ,database)
 129            (,expression-var ,expression))
 130        (handler-bind ((postgresql-warning
 131                        (lambda (c)
 132                          (convert-to-clsql-warning ,database-var c)))
 133                       (postgresql-error
 134                        (lambda (c)
 135                          (convert-to-clsql-error
 136                           ,database-var ,expression-var c))))
 137          ;; KMR - removed double @@
 138          ,@body))))
 139
 140 (defmethod database-initialize-database-type ((database-type
 141                                                (eql :postgresql-socket)))
 142   t)
 143
 144 (defclass postgresql-socket-database (database)
 145   ((connection :accessor database-connection :initarg :connection
 146                :type postgresql-connection)))
 147
 148 (defmethod database-type ((database postgresql-socket-database))
 149   :postgresql-socket)
 150
 151 (defmethod database-name-from-spec (connection-spec
 152                                     (database-type (eql :postgresql-socket)))
 153   (check-connection-spec connection-spec database-type
 154                          (host db user password &optional port options tty))
 155   (destructuring-bind (host db user password &optional port options tty)
 156       connection-spec
 157     (declare (ignore password options tty))
 158     (concatenate 'string host (if port ":") (if port port) "/" db "/" user)))
 159
 160 (defmethod database-connect (connection-spec
 161                              (database-type (eql :postgresql-socket)))
 162   (check-connection-spec connection-spec database-type
 163                          (host db user password &optional port options tty))
 164   (destructuring-bind (host db user password &optional
 165                             (port +postgresql-server-default-port+)
 166                             (options "") (tty ""))
 167       connection-spec
 168     (handler-case
 169         (handler-bind ((postgresql-warning
 170                         (lambda (c)
 171                           (warn 'clsql-simple-warning
 172                                 :format-control "~A"
 173                                 :format-arguments
 174                                 (list (princ-to-string c))))))
 175           (open-postgresql-connection :host host :port port
 176                                       :options options :tty tty
 177                                       :database db :user user
 178                                       :password password))
 179       (postgresql-error (c)
 180         ;; Connect failed
 181         (error 'clsql-connect-error
 182                :database-type database-type
 183                :connection-spec connection-spec
 184                :errno (type-of c)
 185                :error (postgresql-condition-message c)))
 186       (:no-error (connection)
 187                  ;; Success, make instance
 188                  (make-instance 'postgresql-socket-database
 189                                 :name (database-name-from-spec connection-spec
 190                                                                database-type)
 191                                 :connection-spec connection-spec
 192                                 :connection connection)))))
 193
 194 (defmethod database-disconnect ((database postgresql-socket-database))
 195   (close-postgresql-connection (database-connection database))
 196   t)
 197
 198 (defmethod database-query (expression (database postgresql-socket-database) types)
 199   (let ((connection (database-connection database)))
 200     (with-postgresql-handlers (database expression)
 201       (start-query-execution connection expression)
 202       (multiple-value-bind (status cursor)
 203           (wait-for-query-results connection)
 204         (unless (eq status :cursor)
 205           (close-postgresql-connection connection)
 206           (error 'clsql-sql-error
 207                  :database database
 208                  :expression expression
 209                  :errno 'missing-result
 210                  :error "Didn't receive result cursor for query."))
 211         (setq types (canonicalize-types types cursor))
 212         (loop for row = (read-cursor-row cursor types)
 213               while row
 214               collect row
 215               finally
 216               (unless (null (wait-for-query-results connection))
 217                 (close-postgresql-connection connection)
 218                 (error 'clsql-sql-error
 219                        :database database
 220                        :expression expression
 221                        :errno 'multiple-results
 222                        :error "Received multiple results for query.")))))))
 223
 224 (defmethod database-execute-command
 225     (expression (database postgresql-socket-database))
 226   (let ((connection (database-connection database)))
 227     (with-postgresql-handlers (database expression)
 228       (start-query-execution connection expression)
 229       (multiple-value-bind (status result)
 230           (wait-for-query-results connection)
 231         (when (eq status :cursor)
 232           (loop
 233               (multiple-value-bind (row stuff)
 234                   (skip-cursor-row result)
 235                 (unless row
 236                   (setq status :completed result stuff)
 237                   (return)))))
 238         (cond
 239           ((null status)
 240            t)
 241           ((eq status :completed)
 242            (unless (null (wait-for-query-results connection))
 243              (close-postgresql-connection connection)
 244              (error 'clsql-sql-error
 245                     :database database
 246                     :expression expression
 247                     :errno 'multiple-results
 248                     :error "Received multiple results for command."))
 249            result)
 250           (t
 251            (close-postgresql-connection connection)
 252            (error 'clsql-sql-error
 253                   :database database
 254                   :expression expression
 255                   :errno 'missing-result
 256                   :error "Didn't receive completion for command.")))))))
 257
 258 (defstruct postgresql-socket-result-set
 259   (done nil)
 260   (cursor nil)
 261   (types nil))
 262
 263 (defmethod database-query-result-set (expression (database postgresql-socket-database)
 264                                       &key full-set types
 265      )
 266   (declare (ignore full-set))
 267   (let ((connection (database-connection database)))
 268     (with-postgresql-handlers (database expression)
 269       (start-query-execution connection expression)
 270       (multiple-value-bind (status cursor)
 271           (wait-for-query-results connection)
 272         (unless (eq status :cursor)
 273           (close-postgresql-connection connection)
 274           (error 'clsql-sql-error
 275                  :database database
 276                  :expression expression
 277                  :errno 'missing-result
 278                  :error "Didn't receive result cursor for query."))
 279         (values (make-postgresql-socket-result-set
 280                  :done nil
 281                  :cursor cursor
 282                  :types (canonicalize-types types cursor))
 283                 (length (postgresql-cursor-fields cursor)))))))
 284
 285 (defmethod database-dump-result-set (result-set
 286                                      (database postgresql-socket-database))
 287   (if (postgresql-socket-result-set-done result-set)
 288       t
 289       (with-postgresql-handlers (database)
 290         (loop while (skip-cursor-row
 291                      (postgresql-socket-result-set-cursor result-set))
 292           finally (setf (postgresql-socket-result-set-done result-set) t)))))
 293
 294 (defmethod database-store-next-row (result-set
 295                                     (database postgresql-socket-database)
 296                                     list)
 297   (let ((cursor (postgresql-socket-result-set-cursor result-set)))
 298     (with-postgresql-handlers (database)
 299       (if (copy-cursor-row cursor
 300                            list
 301                            (postgresql-socket-result-set-types
 302                             result-set))
 303           t
 304           (prog1 nil
 305             (setf (postgresql-socket-result-set-done result-set) t)
 306             (wait-for-query-results (database-connection database)))))))
 307
 308 (when (clsql-base-sys:database-type-library-loaded :postgresql-socket)
 309   (clsql-base-sys:initialize-database-type :database-type :postgresql-socket))