interfaces/postgresql/postgresql-sql.cl

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          postgresql-sql.sql
   6 ;;;; Purpose:       High-level PostgreSQL interface using UFFI
   7 ;;;; Programmers:   Kevin M. Rosenberg based on
   8 ;;;;                Original code by Pierre R. Mai
   9 ;;;; Date Started:  Feb 2002
  10 ;;;;
  11 ;;;; $Id: postgresql-sql.cl,v 1.10 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
  25     (:use :common-lisp :clsql-sys :postgresql :clsql-uffi)
  26     (:export #:postgresql-database)
  27     (:documentation "This is the CLSQL interface to PostgreSQL."))
  28
  29 (in-package :clsql-postgresql)
  30
  31 ;;; Field conversion functions
  32
  33 (defun canonicalize-types (types num-fields res-ptr)
  34   (cond
  35    ((listp types)
  36     (canonicalize-type-list types num-fields))
  37    ((eq types :auto)
  38     (let ((new-types '()))
  39       (dotimes (i num-fields)
  40         (declare (fixnum i))
  41         (let* ((type (PQftype res-ptr i)))
  42           (push
  43            (case type
  44              ((#.pgsql-ftype#bytea
  45                #.pgsql-ftype#int2
  46                #.pgsql-ftype#int4)
  47               :int)
  48              (#.pgsql-ftype#int8
  49               :longlong)
  50              ((#.pgsql-ftype#float4
  51                #.pgsql-ftype#float8)
  52               :double)
  53              (otherwise
  54               t))
  55            new-types)))
  56       (nreverse new-types)))
  57    (t
  58     nil)))
  59
  60
  61 (defun tidy-error-message (message)
  62   (unless (stringp message)
  63     (setq message (uffi:convert-from-foreign-string message)))
  64   (let ((message (string-right-trim '(#\Return #\Newline) message)))
  65     (cond
  66       ((< (length message) (length "ERROR:"))
  67        message)
  68       ((string= message "ERROR:" :end1 6)
  69        (string-left-trim '(#\Space) (subseq message 6)))
  70       (t
  71        message))))
  72
  73 (defmethod database-initialize-database-type ((database-type
  74                                                (eql :postgresql)))
  75   t)
  76
  77 (uffi:def-type pgsql-conn-def pgsql-conn)
  78 (uffi:def-type pgsql-result-def pgsql-result)
  79
  80
  81 (defclass postgresql-database (database)
  82   ((conn-ptr :accessor database-conn-ptr :initarg :conn-ptr
  83              :type pgsql-conn-def)))
  84
  85 (defmethod database-name-from-spec (connection-spec (database-type
  86                                                      (eql :postgresql)))
  87   (check-connection-spec connection-spec database-type
  88                          (host db user password &optional port options tty))
  89   (destructuring-bind (host db user password &optional port options tty)
  90       connection-spec
  91     (declare (ignore password options tty))
  92     (concatenate 'string host (if port ":") (if port port) "/" db "/" user)))
  93
  94
  95 (defmethod database-connect (connection-spec (database-type (eql :postgresql)))
  96   (check-connection-spec connection-spec database-type
  97                          (host db user password &optional port options tty))
  98   (destructuring-bind (host db user password &optional port options tty)
  99       connection-spec
 100     (uffi:with-cstrings ((host-native host)
 101                          (user-native user)
 102                          (password-native password)
 103                          (db-native db)
 104                          (port-native port)
 105                          (options-native options)
 106                          (tty-native tty))
 107       (let ((connection (PQsetdbLogin host-native port-native
 108                                       options-native tty-native
 109                                       db-native user-native
 110                                       password-native)))
 111         (declare (type pgsql-conn-def connection))
 112         (when (not (eq (PQstatus connection)
 113                        pgsql-conn-status-type#connection-ok))
 114           (error 'clsql-connect-error
 115                  :database-type database-type
 116                  :connection-spec connection-spec
 117                  :errno (PQstatus connection)
 118                  :error (tidy-error-message
 119                          (PQerrorMessage connection))))
 120         (make-instance 'postgresql-database
 121                        :name (database-name-from-spec connection-spec
 122                                                       database-type)
 123                        :conn-ptr connection)))))
 124
 125
 126 (defmethod database-disconnect ((database postgresql-database))
 127   (PQfinish (database-conn-ptr database))
 128   (setf (database-conn-ptr database) nil)
 129   t)
 130
 131 (defmethod database-query (query-expression (database postgresql-database) types)
 132   (let ((conn-ptr (database-conn-ptr database)))
 133     (declare (type pgsql-conn-def conn-ptr))
 134     (uffi:with-cstring (query-native query-expression)
 135       (let ((result (PQexec conn-ptr query-native)))
 136         (when (uffi:null-pointer-p result)
 137           (error 'clsql-sql-error
 138                  :database database
 139                  :expression query-expression
 140                  :errno nil
 141                  :error (tidy-error-message (PQerrorMessage conn-ptr))))
 142         (unwind-protect
 143             (case (PQresultStatus result)
 144               (#.pgsql-exec-status-type#empty-query
 145                nil)
 146               (#.pgsql-exec-status-type#tuples-ok
 147                (let ((num-fields (PQnfields result)))
 148                  (setq types
 149                    (canonicalize-types types num-fields
 150                                              result))
 151                  (loop for tuple-index from 0 below (PQntuples result)
 152                        collect
 153                        (loop for i from 0 below num-fields
 154                              collect
 155                              (if (zerop (PQgetisnull result tuple-index i))
 156                                  (convert-raw-field
 157                                   (PQgetvalue result tuple-index i)
 158                                   types i)
 159                                  nil)))))
 160               (t
 161                (error 'clsql-sql-error
 162                       :database database
 163                       :expression query-expression
 164                       :errno (PQresultStatus result)
 165                       :error (tidy-error-message
 166                               (PQresultErrorMessage result)))))
 167           (PQclear result))))))
 168
 169 (defmethod database-execute-command (sql-expression
 170                                      (database postgresql-database))
 171   (let ((conn-ptr (database-conn-ptr database)))
 172     (declare (type pgsql-conn-def conn-ptr))
 173     (uffi:with-cstring (sql-native sql-expression)
 174       (let ((result (PQexec conn-ptr sql-native)))
 175         (when (uffi:null-pointer-p result)
 176           (error 'clsql-sql-error
 177                  :database database
 178                  :expression sql-expression
 179                  :errno nil
 180                  :error (tidy-error-message (PQerrorMessage conn-ptr))))
 181         (unwind-protect
 182             (case (PQresultStatus result)
 183               (#.pgsql-exec-status-type#command-ok
 184                t)
 185               ((#.pgsql-exec-status-type#empty-query
 186                 #.pgsql-exec-status-type#tuples-ok)
 187                (warn "Strange result...")
 188                t)
 189               (t
 190                (error 'clsql-sql-error
 191                       :database database
 192                       :expression sql-expression
 193                       :errno (PQresultStatus result)
 194                       :error (tidy-error-message
 195                               (PQresultErrorMessage result)))))
 196           (PQclear result))))))
 197
 198 (defstruct postgresql-result-set
 199   (res-ptr (uffi:make-null-pointer 'pgsql-result)
 200            :type pgsql-result-def)
 201   (types nil)
 202   (num-tuples 0 :type integer)
 203   (num-fields 0 :type integer)
 204   (tuple-index 0 :type integer))
 205
 206 (defmethod database-query-result-set (query-expression (database postgresql-database)
 207                                       &key full-set types)
 208   (let ((conn-ptr (database-conn-ptr database)))
 209     (declare (type pgsql-conn-def conn-ptr))
 210     (uffi:with-cstring (query-native query-expression)
 211       (let ((result (PQexec conn-ptr query-native)))
 212         (when (uffi:null-pointer-p result)
 213           (error 'clsql-sql-error
 214                  :database database
 215                  :expression query-expression
 216                  :errno nil
 217                  :error (tidy-error-message (PQerrorMessage conn-ptr))))
 218         (case (PQresultStatus result)
 219           ((#.pgsql-exec-status-type#empty-query
 220             #.pgsql-exec-status-type#tuples-ok)
 221            (let ((result-set (make-postgresql-result-set
 222                         :res-ptr result
 223                         :num-fields (PQnfields result)
 224                         :num-tuples (PQntuples result)
 225                         :types (canonicalize-types
 226                                       types
 227                                       (PQnfields result)
 228                                       result))))
 229              (if full-set
 230                  (values result-set
 231                          (PQnfields result)
 232                          (PQntuples result))
 233                  (values result-set
 234                          (PQnfields result)))))
 235           (t
 236            (unwind-protect
 237                (error 'clsql-sql-error
 238                       :database database
 239                       :expression query-expression
 240                       :errno (PQresultStatus result)
 241                       :error (tidy-error-message
 242                               (PQresultErrorMessage result)))
 243              (PQclear result))))))))
 244
 245 (defmethod database-dump-result-set (result-set (database postgresql-database))
 246   (let ((res-ptr (postgresql-result-set-res-ptr result-set)))
 247     (declare (type pgsql-result-def res-ptr))
 248     (PQclear res-ptr)
 249     t))
 250
 251 (defmethod database-store-next-row (result-set (database postgresql-database)
 252                                     list)
 253   (let ((result (postgresql-result-set-res-ptr result-set))
 254         (types (postgresql-result-set-types result-set)))
 255     (declare (type pgsql-result-def result))
 256     (if (>= (postgresql-result-set-tuple-index result-set)
 257             (postgresql-result-set-num-tuples result-set))
 258         nil
 259       (loop with tuple-index = (postgresql-result-set-tuple-index result-set)
 260           for i from 0 below (postgresql-result-set-num-fields result-set)
 261           for rest on list
 262           do
 263             (setf (car rest)
 264               (if (zerop (PQgetisnull result tuple-index i))
 265                   (convert-raw-field
 266                    (PQgetvalue result tuple-index i)
 267                    types i)
 268                 nil))
 269           finally
 270             (incf (postgresql-result-set-tuple-index result-set))
 271             (return list)))))