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