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