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.14 2002/04/23 18:28:02 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   (if (null types)
  56       nil
  57       (let ((auto-list (make-type-list-for-auto num-fields res-ptr)))
  58         (cond
  59           ((listp types)
  60            (canonicalize-type-list types auto-list))
  61           ((eq types :auto)
  62            auto-list)
  63           (t
  64            nil)))))
  65
  66 (defun tidy-error-message (message)
  67   (unless (stringp message)
  68     (setq message (uffi:convert-from-foreign-string message)))
  69   (let ((message (string-right-trim '(#\Return #\Newline) message)))
  70     (cond
  71       ((< (length message) (length "ERROR:"))
  72        message)
  73       ((string= message "ERROR:" :end1 6)
  74        (string-left-trim '(#\Space) (subseq message 6)))
  75       (t
  76        message))))
  77
  78 (defmethod database-initialize-database-type ((database-type
  79                                                (eql :postgresql)))
  80   t)
  81
  82 (uffi:def-type pgsql-conn-def pgsql-conn)
  83 (uffi:def-type pgsql-result-def pgsql-result)
  84
  85
  86 (defclass postgresql-database (database)
  87   ((conn-ptr :accessor database-conn-ptr :initarg :conn-ptr
  88              :type pgsql-conn-def)))
  89
  90 (defmethod database-name-from-spec (connection-spec (database-type
  91                                                      (eql :postgresql)))
  92   (check-connection-spec connection-spec database-type
  93                          (host db user password &optional port options tty))
  94   (destructuring-bind (host db user password &optional port options tty)
  95       connection-spec
  96     (declare (ignore password options tty))
  97     (concatenate 'string host (if port ":") (if port port) "/" db "/" user)))
  98
  99
 100 (defmethod database-connect (connection-spec (database-type (eql :postgresql)))
 101   (check-connection-spec connection-spec database-type
 102                          (host db user password &optional port options tty))
 103   (destructuring-bind (host db user password &optional port options tty)
 104       connection-spec
 105     (uffi:with-cstrings ((host-native host)
 106                          (user-native user)
 107                          (password-native password)
 108                          (db-native db)
 109                          (port-native port)
 110                          (options-native options)
 111                          (tty-native tty))
 112       (let ((connection (PQsetdbLogin host-native port-native
 113                                       options-native tty-native
 114                                       db-native user-native
 115                                       password-native)))
 116         (declare (type pgsql-conn-def connection))
 117         (when (not (eq (PQstatus connection)
 118                        pgsql-conn-status-type#connection-ok))
 119           (error 'clsql-connect-error
 120                  :database-type database-type
 121                  :connection-spec connection-spec
 122                  :errno (PQstatus connection)
 123                  :error (tidy-error-message
 124                          (PQerrorMessage connection))))
 125         (make-instance 'postgresql-database
 126                        :name (database-name-from-spec connection-spec
 127                                                       database-type)
 128                        :conn-ptr connection)))))
 129
 130
 131 (defmethod database-disconnect ((database postgresql-database))
 132   (PQfinish (database-conn-ptr database))
 133   (setf (database-conn-ptr database) nil)
 134   t)
 135
 136 (defmethod database-query (query-expression (database postgresql-database) types)
 137   (let ((conn-ptr (database-conn-ptr database)))
 138     (declare (type pgsql-conn-def conn-ptr))
 139     (uffi:with-cstring (query-native query-expression)
 140       (let ((result (PQexec conn-ptr query-native)))
 141         (when (uffi:null-pointer-p result)
 142           (error 'clsql-sql-error
 143                  :database database
 144                  :expression query-expression
 145                  :errno nil
 146                  :error (tidy-error-message (PQerrorMessage conn-ptr))))
 147         (unwind-protect
 148             (case (PQresultStatus result)
 149               (#.pgsql-exec-status-type#empty-query
 150                nil)
 151               (#.pgsql-exec-status-type#tuples-ok
 152                (let ((num-fields (PQnfields result)))
 153                  (setq types
 154                    (canonicalize-types types num-fields
 155                                              result))
 156                  (loop for tuple-index from 0 below (PQntuples result)
 157                        collect
 158                        (loop for i from 0 below num-fields
 159                              collect
 160                              (if (zerop (PQgetisnull result tuple-index i))
 161                                  (convert-raw-field
 162                                   (PQgetvalue result tuple-index i)
 163                                   types i)
 164                                  nil)))))
 165               (t
 166                (error 'clsql-sql-error
 167                       :database database
 168                       :expression query-expression
 169                       :errno (PQresultStatus result)
 170                       :error (tidy-error-message
 171                               (PQresultErrorMessage result)))))
 172           (PQclear result))))))
 173
 174 (defmethod database-execute-command (sql-expression
 175                                      (database postgresql-database))
 176   (let ((conn-ptr (database-conn-ptr database)))
 177     (declare (type pgsql-conn-def conn-ptr))
 178     (uffi:with-cstring (sql-native sql-expression)
 179       (let ((result (PQexec conn-ptr sql-native)))
 180         (when (uffi:null-pointer-p result)
 181           (error 'clsql-sql-error
 182                  :database database
 183                  :expression sql-expression
 184                  :errno nil
 185                  :error (tidy-error-message (PQerrorMessage conn-ptr))))
 186         (unwind-protect
 187             (case (PQresultStatus result)
 188               (#.pgsql-exec-status-type#command-ok
 189                t)
 190               ((#.pgsql-exec-status-type#empty-query
 191                 #.pgsql-exec-status-type#tuples-ok)
 192                (warn "Strange result...")
 193                t)
 194               (t
 195                (error 'clsql-sql-error
 196                       :database database
 197                       :expression sql-expression
 198                       :errno (PQresultStatus result)
 199                       :error (tidy-error-message
 200                               (PQresultErrorMessage result)))))
 201           (PQclear result))))))
 202
 203 (defstruct postgresql-result-set
 204   (res-ptr (uffi:make-null-pointer 'pgsql-result)
 205            :type pgsql-result-def)
 206   (types nil)
 207   (num-tuples 0 :type integer)
 208   (num-fields 0 :type integer)
 209   (tuple-index 0 :type integer))
 210
 211 (defmethod database-query-result-set (query-expression (database postgresql-database)
 212                                       &key full-set types)
 213   (let ((conn-ptr (database-conn-ptr database)))
 214     (declare (type pgsql-conn-def conn-ptr))
 215     (uffi:with-cstring (query-native query-expression)
 216       (let ((result (PQexec conn-ptr query-native)))
 217         (when (uffi:null-pointer-p result)
 218           (error 'clsql-sql-error
 219                  :database database
 220                  :expression query-expression
 221                  :errno nil
 222                  :error (tidy-error-message (PQerrorMessage conn-ptr))))
 223         (case (PQresultStatus result)
 224           ((#.pgsql-exec-status-type#empty-query
 225             #.pgsql-exec-status-type#tuples-ok)
 226            (let ((result-set (make-postgresql-result-set
 227                         :res-ptr result
 228                         :num-fields (PQnfields result)
 229                         :num-tuples (PQntuples result)
 230                         :types (canonicalize-types
 231                                       types
 232                                       (PQnfields result)
 233                                       result))))
 234              (if full-set
 235                  (values result-set
 236                          (PQnfields result)
 237                          (PQntuples result))
 238                  (values result-set
 239                          (PQnfields result)))))
 240           (t
 241            (unwind-protect
 242                (error 'clsql-sql-error
 243                       :database database
 244                       :expression query-expression
 245                       :errno (PQresultStatus result)
 246                       :error (tidy-error-message
 247                               (PQresultErrorMessage result)))
 248              (PQclear result))))))))
 249
 250 (defmethod database-dump-result-set (result-set (database postgresql-database))
 251   (let ((res-ptr (postgresql-result-set-res-ptr result-set)))
 252     (declare (type pgsql-result-def res-ptr))
 253     (PQclear res-ptr)
 254     t))
 255
 256 (defmethod database-store-next-row (result-set (database postgresql-database)
 257                                     list)
 258   (let ((result (postgresql-result-set-res-ptr result-set))
 259         (types (postgresql-result-set-types result-set)))
 260     (declare (type pgsql-result-def result))
 261     (if (>= (postgresql-result-set-tuple-index result-set)
 262             (postgresql-result-set-num-tuples result-set))
 263         nil
 264       (loop with tuple-index = (postgresql-result-set-tuple-index result-set)
 265           for i from 0 below (postgresql-result-set-num-fields result-set)
 266           for rest on list
 267           do
 268             (setf (car rest)
 269               (if (zerop (PQgetisnull result tuple-index i))
 270                   (convert-raw-field
 271                    (PQgetvalue result tuple-index i)
 272                    types i)
 273                 nil))
 274           finally
 275             (incf (postgresql-result-set-tuple-index result-set))
 276             (return list)))))
 277
 278 ;;; Large objects support (Marc B)
 279
 280 (defmethod database-create-large-object ((database postgresql-database))
 281   (lo-create (database-conn-ptr database)
 282              (logior postgresql::+INV_WRITE+ postgresql::+INV_READ+)))
 283
 284 ;; (MB)the begin/commit/rollback stuff will be removed when with-transaction wil be implemented
 285 (defmethod database-write-large-object ( object-id (data string) (database postgresql-database))
 286   (let ((ptr (database-conn-ptr database))
 287         (length (length data))
 288         (result nil)
 289         (fd nil))
 290     (unwind-protect
 291        (progn
 292          (database-execute-command "begin" database)
 293          (setf fd (lo-open ptr object-id postgresql::+INV_WRITE+))
 294          (when (>= fd 0)
 295            (when (= (lo-write ptr fd data length) length)
 296              (setf result t))))
 297       (progn
 298         (when (and fd (>= fd 0))
 299           (lo-close ptr fd))
 300         (database-execute-command (if result "commit" "rollback") database)))
 301     result))
 302
 303 ;; (MB) the begin/commit/rollback stuff will be removed when with-transaction wil be implemented
 304 (defmethod database-read-large-object (object-id (database postgresql-database))
 305   (let ((ptr (database-conn-ptr database))
 306         (buffer nil)
 307         (result nil)
 308         (length 0)
 309         (fd nil))
 310     (unwind-protect
 311        (progn
 312          (database-execute-command "begin" database)
 313          (setf fd (lo-open ptr object-id postgresql::+INV_READ+))
 314          (when (>= fd 0)
 315            (setf length (lo-lseek ptr fd 0 2))
 316            (lo-lseek ptr fd 0 0)
 317            (when (> length 0)
 318              (setf buffer (uffi:allocate-foreign-string
 319                            length :unsigned t))
 320              (when (= (lo-read ptr fd buffer length) length)
 321                (setf result (uffi:convert-from-foreign-string
 322                              buffer :length length :null-terminated-p nil))))))
 323       (progn
 324         (when buffer (uffi:free-foreign-object buffer))
 325         (when (and fd (>= fd 0)) (lo-close ptr fd))
 326         (database-execute-command (if result "commit" "rollback") database)))
 327     result))
 328
 329 (defmethod database-delete-large-object (object-id (database postgresql-database))
 330   (lo-unlink (database-conn-ptr database) object-id))