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