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.2 2002/03/24 18:08:27 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
  25 (defpackage :clsql-postgresql-socket
  26     (:use :common-lisp :clsql-sys :postgresql-socket)
  27     (:export #:postgresql-socket-database)
  28     (:documentation "This is the CLSQL socket interface to PostgreSQL."))
  29
  30 (in-package :clsql-postgresql-socket)
  31
  32 (defun convert-to-clsql-warning (database condition)
  33   (warn 'clsql-database-warning :database database
  34         :message (postgresql-condition-message condition)))
  35
  36 (defun convert-to-clsql-error (database expression condition)
  37   (error 'clsql-sql-error :database database
  38          :expression expression
  39          :errno (type-of condition)
  40          :error (postgresql-condition-message condition)))
  41
  42 (defmacro with-postgresql-handlers
  43     ((database &optional expression)
  44      &body body)
  45   (let ((database-var (gensym))
  46         (expression-var (gensym)))
  47     `(let ((,database-var ,database)
  48            (,expression-var ,expression))
  49        (handler-bind ((postgresql-warning
  50                        (lambda (c)
  51                          (convert-to-clsql-warning ,database-var c)))
  52                       (postgresql-error
  53                        (lambda (c)
  54                          (convert-to-clsql-error
  55                           ,database-var ,expression-var c))))
  56          ;; KMR - removed double @@
  57          ,@body))))
  58
  59 (defmethod database-initialize-database-type
  60     ((database-type (eql :postgresql-socket)))
  61   t)
  62
  63 (defclass postgresql-socket-database (database)
  64   ((connection :accessor database-connection :initarg :connection
  65                :type postgresql-connection)))
  66
  67 (defmethod database-name-from-spec
  68     (connection-spec (database-type (eql :postgresql-socket)))
  69   (check-connection-spec connection-spec database-type
  70                          (host db user password &optional port options tty))
  71   (destructuring-bind (host db user password &optional port options tty)
  72       connection-spec
  73     (declare (ignore password options tty))
  74     (concatenate 'string host (if port ":") (if port port) "/" db "/" user)))
  75
  76 (defmethod database-connect
  77     (connection-spec (database-type (eql :postgresql-socket)))
  78   (check-connection-spec connection-spec database-type
  79                          (host db user password &optional port options tty))
  80   (destructuring-bind (host db user password &optional
  81                             (port +postgresql-server-default-port+)
  82                             (options "") (tty ""))
  83       connection-spec
  84     (handler-case
  85         (handler-bind ((postgresql-warning
  86                         (lambda (c)
  87                           (warn 'clsql-simple-warning
  88                                 :format-control "~A"
  89                                 :format-arguments
  90                                 (list (princ-to-string c))))))
  91           (open-postgresql-connection :host host :port port
  92                                       :options options :tty tty
  93                                       :database db :user user
  94                                       :password password))
  95       (:no-error (connection)
  96         ;; Success, make instance
  97         (make-instance 'postgresql-socket-database
  98                        :name (database-name-from-spec connection-spec
  99                                                       database-type)
 100                        :connection connection))
 101       (postgresql-error (c)
 102         ;; Connect failed
 103         (error 'clsql-connect-error
 104                :database-type database-type
 105                :connection-spec connection-spec
 106                :errno (type-of c)
 107                :error (postgresql-condition-message c))))))
 108
 109 (defmethod database-disconnect ((database postgresql-socket-database))
 110   (close-postgresql-connection (database-connection database))
 111   t)
 112
 113 (defmethod database-query (expression (database postgresql-socket-database) field-types)
 114   (let ((connection (database-connection database)))
 115     (with-postgresql-handlers (database expression)
 116       (start-query-execution connection expression)
 117       (multiple-value-bind (status cursor)
 118           (wait-for-query-results connection)
 119         (unless (eq status :cursor)
 120           (close-postgresql-connection connection)
 121           (error 'clsql-sql-error
 122                  :database database
 123                  :expression expression
 124                  :errno 'missing-result
 125                  :error "Didn't receive result cursor for query."))
 126         (loop for row = (read-cursor-row cursor)
 127               while row
 128               collect row
 129               finally
 130               (unless (null (wait-for-query-results connection))
 131                 (close-postgresql-connection connection)
 132                 (error 'clsql-sql-error
 133                        :database database
 134                        :expression expression
 135                        :errno 'multiple-results
 136                        :error "Received multiple results for query.")))))))
 137
 138 (defmethod database-execute-command
 139     (expression (database postgresql-socket-database))
 140   (let ((connection (database-connection database)))
 141     (with-postgresql-handlers (database expression)
 142       (start-query-execution connection expression)
 143       (multiple-value-bind (status result)
 144           (wait-for-query-results connection)
 145         (when (eq status :cursor)
 146           (loop
 147               (multiple-value-bind (row stuff)
 148                   (skip-cursor-row result)
 149                 (unless row
 150                   (setq status :completed result stuff)
 151                   (return)))))
 152         (cond
 153           ((null status)
 154            t)
 155           ((eq status :completed)
 156            (unless (null (wait-for-query-results connection))
 157              (close-postgresql-connection connection)
 158              (error 'clsql-sql-error
 159                     :database database
 160                     :expression expression
 161                     :errno 'multiple-results
 162                     :error "Received multiple results for command."))
 163            result)
 164           (t
 165            (close-postgresql-connection connection)
 166            (error 'clsql-sql-error
 167                   :database database
 168                   :expression expression
 169                   :errno 'missing-result
 170                   :error "Didn't receive completion for command.")))))))
 171
 172 (defstruct postgresql-socket-result-set
 173   (done nil)
 174   (cursor nil)
 175   (field-types nil :type cons))
 176
 177 (defmethod database-query-result-set (expression (database postgresql-socket-database)
 178                                       &key full-set field-types
 179      )
 180   (declare (ignore full-set))
 181   (let ((connection (database-connection database)))
 182     (with-postgresql-handlers (database expression)
 183       (start-query-execution connection expression)
 184       (multiple-value-bind (status cursor)
 185           (wait-for-query-results connection)
 186         (unless (eq status :cursor)
 187           (close-postgresql-connection connection)
 188           (error 'clsql-sql-error
 189                  :database database
 190                  :expression expression
 191                  :errno 'missing-result
 192                  :error "Didn't receive result cursor for query."))
 193         (values (make-postgresql-socket-result-set
 194                  :done nil
 195                  :cursor cursor)
 196                 (length (postgresql-cursor-fields cursor)))))))
 197
 198 (defmethod database-dump-result-set (result-set
 199                                      (database postgresql-socket-database))
 200   (if (postgresql-socket-result-set-done result-set)
 201       t
 202       (with-postgresql-handlers (database)
 203         (loop while (skip-cursor-row
 204                      (postgresql-socket-result-set-cursor result-set))
 205           finally (setf (postgresql-socket-result-set-done result-set) t)))))
 206
 207 (defmethod database-store-next-row (result-set
 208                                     (database postgresql-socket-database)
 209                                     list)
 210   (let ((cursor (postgresql-socket-result-set-cursor result-set)))
 211     (with-postgresql-handlers (database)
 212       (if (copy-cursor-row cursor list)
 213           t
 214           (prog1 nil
 215             (setf (postgresql-socket-result-set-done result-set) t)
 216             (wait-for-query-results (database-connection database)))))))