interfaces/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.8 2002/03/27 12:09:39 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-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 ;; Field type conversion
  32
  33 (defun make-type-list-for-auto (cursor)
  34   (let* ((fields (postgresql-cursor-fields cursor))
  35          (num-fields (length fields))
  36          (new-types '()))
  37     (dotimes (i num-fields)
  38       (declare (fixnum i))
  39       (push (canonical-field-type fields i) new-types))
  40     (nreverse new-types)))
  41
  42 (defun canonical-field-type (fields index)
  43   "Extracts canonical field type from fields list"
  44   (let ((oid (cadr (nth index fields))))
  45     (case oid
  46       ((#.pgsql-ftype#bytea
  47         #.pgsql-ftype#int2
  48         #.pgsql-ftype#int4)
  49        :int32)
  50       (#.pgsql-ftype#int8
  51        :int64)
  52       ((#.pgsql-ftype#float4
  53         #.pgsql-ftype#float8)
  54        :double)
  55       (otherwise
  56        t))))
  57
  58 (defun canonicalize-types (types cursor)
  59   (let ((auto-list (make-type-list-for-auto cursor)))
  60     (cond
  61       ((listp types)
  62        (canonicalize-type-list types auto-list))
  63       ((eq types :auto)
  64        auto-list)
  65       (t
  66        nil))))
  67
  68 (defun canonicalize-type-list (types auto-list)
  69   "Ensure a field type list meets expectations.
  70 Duplicated from clsql-uffi package so that this interface
  71 doesn't depend on UFFI."
  72   (let ((length-types (length types))
  73         (new-types '()))
  74     (loop for i from 0 below (length auto-list)
  75           do
  76           (if (>= i length-types)
  77               (push t new-types) ;; types is shorted than num-fields
  78               (push
  79                (case (nth i types)
  80                  (:int
  81                   (case (nth i auto-list)
  82                     (:int32
  83                      :int32)
  84                     (:int64
  85                      :int64)
  86                     (t
  87                      t)))
  88                  (:double
  89                   (case (nth i auto-list)
  90                     (:double
  91                      :double)
  92                     (t
  93                      t)))
  94                  (t
  95                   t))
  96                new-types)))
  97     (nreverse new-types)))
  98
  99
 100 (defun convert-to-clsql-warning (database condition)
 101   (warn 'clsql-database-warning :database database
 102         :message (postgresql-condition-message condition)))
 103
 104 (defun convert-to-clsql-error (database expression condition)
 105   (error 'clsql-sql-error :database database
 106          :expression expression
 107          :errno (type-of condition)
 108          :error (postgresql-condition-message condition)))
 109
 110 (defmacro with-postgresql-handlers
 111     ((database &optional expression)
 112      &body body)
 113   (let ((database-var (gensym))
 114         (expression-var (gensym)))
 115     `(let ((,database-var ,database)
 116            (,expression-var ,expression))
 117        (handler-bind ((postgresql-warning
 118                        (lambda (c)
 119                          (convert-to-clsql-warning ,database-var c)))
 120                       (postgresql-error
 121                        (lambda (c)
 122                          (convert-to-clsql-error
 123                           ,database-var ,expression-var c))))
 124          ;; KMR - removed double @@
 125          ,@body))))
 126
 127 (defmethod database-initialize-database-type
 128     ((database-type (eql :postgresql-socket)))
 129   t)
 130
 131 (defclass postgresql-socket-database (database)
 132   ((connection :accessor database-connection :initarg :connection
 133                :type postgresql-connection)))
 134
 135 (defmethod database-name-from-spec
 136     (connection-spec (database-type (eql :postgresql-socket)))
 137   (check-connection-spec connection-spec database-type
 138                          (host db user password &optional port options tty))
 139   (destructuring-bind (host db user password &optional port options tty)
 140       connection-spec
 141     (declare (ignore password options tty))
 142     (concatenate 'string host (if port ":") (if port port) "/" db "/" user)))
 143
 144 (defmethod database-connect
 145     (connection-spec (database-type (eql :postgresql-socket)))
 146   (check-connection-spec connection-spec database-type
 147                          (host db user password &optional port options tty))
 148   (destructuring-bind (host db user password &optional
 149                             (port +postgresql-server-default-port+)
 150                             (options "") (tty ""))
 151       connection-spec
 152     (handler-case
 153         (handler-bind ((postgresql-warning
 154                         (lambda (c)
 155                           (warn 'clsql-simple-warning
 156                                 :format-control "~A"
 157                                 :format-arguments
 158                                 (list (princ-to-string c))))))
 159           (open-postgresql-connection :host host :port port
 160                                       :options options :tty tty
 161                                       :database db :user user
 162                                       :password password))
 163       (:no-error (connection)
 164         ;; Success, make instance
 165         (make-instance 'postgresql-socket-database
 166                        :name (database-name-from-spec connection-spec
 167                                                       database-type)
 168                        :connection connection))
 169       (postgresql-error (c)
 170         ;; Connect failed
 171         (error 'clsql-connect-error
 172                :database-type database-type
 173                :connection-spec connection-spec
 174                :errno (type-of c)
 175                :error (postgresql-condition-message c))))))
 176
 177 (defmethod database-disconnect ((database postgresql-socket-database))
 178   (close-postgresql-connection (database-connection database))
 179   t)
 180
 181 (defmethod database-query (expression (database postgresql-socket-database) types)
 182   (let ((connection (database-connection database)))
 183     (with-postgresql-handlers (database expression)
 184       (start-query-execution connection expression)
 185       (multiple-value-bind (status cursor)
 186           (wait-for-query-results connection)
 187         (unless (eq status :cursor)
 188           (close-postgresql-connection connection)
 189           (error 'clsql-sql-error
 190                  :database database
 191                  :expression expression
 192                  :errno 'missing-result
 193                  :error "Didn't receive result cursor for query."))
 194         (setq types (canonicalize-types types cursor))
 195         (loop for row = (read-cursor-row cursor types)
 196               while row
 197               collect row
 198               finally
 199               (unless (null (wait-for-query-results connection))
 200                 (close-postgresql-connection connection)
 201                 (error 'clsql-sql-error
 202                        :database database
 203                        :expression expression
 204                        :errno 'multiple-results
 205                        :error "Received multiple results for query.")))))))
 206
 207 (defmethod database-execute-command
 208     (expression (database postgresql-socket-database))
 209   (let ((connection (database-connection database)))
 210     (with-postgresql-handlers (database expression)
 211       (start-query-execution connection expression)
 212       (multiple-value-bind (status result)
 213           (wait-for-query-results connection)
 214         (when (eq status :cursor)
 215           (loop
 216               (multiple-value-bind (row stuff)
 217                   (skip-cursor-row result)
 218                 (unless row
 219                   (setq status :completed result stuff)
 220                   (return)))))
 221         (cond
 222           ((null status)
 223            t)
 224           ((eq status :completed)
 225            (unless (null (wait-for-query-results connection))
 226              (close-postgresql-connection connection)
 227              (error 'clsql-sql-error
 228                     :database database
 229                     :expression expression
 230                     :errno 'multiple-results
 231                     :error "Received multiple results for command."))
 232            result)
 233           (t
 234            (close-postgresql-connection connection)
 235            (error 'clsql-sql-error
 236                   :database database
 237                   :expression expression
 238                   :errno 'missing-result
 239                   :error "Didn't receive completion for command.")))))))
 240
 241 (defstruct postgresql-socket-result-set
 242   (done nil)
 243   (cursor nil)
 244   (types nil))
 245
 246 (defmethod database-query-result-set (expression (database postgresql-socket-database)
 247                                       &key full-set types
 248      )
 249   (declare (ignore full-set))
 250   (let ((connection (database-connection database)))
 251     (with-postgresql-handlers (database expression)
 252       (start-query-execution connection expression)
 253       (multiple-value-bind (status cursor)
 254           (wait-for-query-results connection)
 255         (unless (eq status :cursor)
 256           (close-postgresql-connection connection)
 257           (error 'clsql-sql-error
 258                  :database database
 259                  :expression expression
 260                  :errno 'missing-result
 261                  :error "Didn't receive result cursor for query."))
 262         (values (make-postgresql-socket-result-set
 263                  :done nil
 264                  :cursor cursor
 265                  :types (canonicalize-types types cursor))
 266                 (length (postgresql-cursor-fields cursor)))))))
 267
 268 (defmethod database-dump-result-set (result-set
 269                                      (database postgresql-socket-database))
 270   (if (postgresql-socket-result-set-done result-set)
 271       t
 272       (with-postgresql-handlers (database)
 273         (loop while (skip-cursor-row
 274                      (postgresql-socket-result-set-cursor result-set))
 275           finally (setf (postgresql-socket-result-set-done result-set) t)))))
 276
 277 (defmethod database-store-next-row (result-set
 278                                     (database postgresql-socket-database)
 279                                     list)
 280   (let ((cursor (postgresql-socket-result-set-cursor result-set)))
 281     (with-postgresql-handlers (database)
 282       (if (copy-cursor-row cursor
 283                            list
 284                            (postgresql-socket-result-set-types
 285                             result-set))
 286           t
 287           (prog1 nil
 288             (setf (postgresql-socket-result-set-done result-set) t)
 289             (wait-for-query-results (database-connection database)))))))