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