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