db-postgresql/postgresql-sql.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          postgresql-sql.lisp
   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.lisp,v 1.3 2003/07/21 01:45:45 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 (in-package #:cl-user)
  22
  23 (defpackage #:clsql-postgresql
  24     (:use #:common-lisp #:clsql-base-sys #:postgresql #:clsql-uffi)
  25     (:export #:postgresql-database)
  26     (:documentation "This is the CLSQL interface to PostgreSQL."))
  27
  28 (in-package #:clsql-postgresql)
  29
  30 ;;; Field conversion functions
  31
  32 (defun make-type-list-for-auto (num-fields res-ptr)
  33   (let ((new-types '()))
  34     (dotimes (i num-fields)
  35       (declare (fixnum i))
  36       (let* ((type (PQftype res-ptr i)))
  37         (push
  38          (case type
  39            ((#.pgsql-ftype#bytea
  40              #.pgsql-ftype#int2
  41              #.pgsql-ftype#int4)
  42             :int32)
  43            (#.pgsql-ftype#int8
  44             :int64)
  45            ((#.pgsql-ftype#float4
  46              #.pgsql-ftype#float8)
  47             :double)
  48            (otherwise
  49             t))
  50          new-types)))
  51       (nreverse new-types)))
  52
  53 (defun canonicalize-types (types num-fields res-ptr)
  54   (if (null types)
  55       nil
  56       (let ((auto-list (make-type-list-for-auto num-fields res-ptr)))
  57         (cond
  58           ((listp types)
  59            (canonicalize-type-list types auto-list))
  60           ((eq types :auto)
  61            auto-list)
  62           (t
  63            nil)))))
  64
  65 (defun tidy-error-message (message)
  66   (unless (stringp message)
  67     (setq message (uffi:convert-from-foreign-string message)))
  68   (let ((message (string-right-trim '(#\Return #\Newline) message)))
  69     (cond
  70       ((< (length message) (length "ERROR:"))
  71        message)
  72       ((string= message "ERROR:" :end1 6)
  73        (string-left-trim '(#\Space) (subseq message 6)))
  74       (t
  75        message))))
  76
  77 (defmethod database-initialize-database-type ((database-type
  78                                                (eql :postgresql)))
  79   t)
  80
  81 (uffi:def-type pgsql-conn-def pgsql-conn)
  82 (uffi:def-type pgsql-result-def pgsql-result)
  83
  84
  85 (defclass postgresql-database (database)
  86   ((conn-ptr :accessor database-conn-ptr :initarg :conn-ptr
  87              :type pgsql-conn-def)))
  88
  89 (defmethod database-type ((database postgresql-database))
  90   :postgresql)
  91
  92 (defmethod database-name-from-spec (connection-spec (database-type
  93                                                      (eql :postgresql)))
  94   (check-connection-spec connection-spec database-type
  95                          (host db user password &optional port options tty))
  96   (destructuring-bind (host db user password &optional port options tty)
  97       connection-spec
  98     (declare (ignore password options tty))
  99     (concatenate 'string host (if port ":") (if port port) "/" db "/" user)))
 100
 101
 102 (defmethod database-connect (connection-spec (database-type (eql :postgresql)))
 103   (check-connection-spec connection-spec database-type
 104                          (host db user password &optional port options tty))
 105   (destructuring-bind (host db user password &optional port options tty)
 106       connection-spec
 107     (uffi:with-cstrings ((host-native host)
 108                          (user-native user)
 109                          (password-native password)
 110                          (db-native db)
 111                          (port-native port)
 112                          (options-native options)
 113                          (tty-native tty))
 114       (let ((connection (PQsetdbLogin host-native port-native
 115                                       options-native tty-native
 116                                       db-native user-native
 117                                       password-native)))
 118         (declare (type pgsql-conn-def connection))
 119         (when (not (eq (PQstatus connection)
 120                        pgsql-conn-status-type#connection-ok))
 121           (error 'clsql-connect-error
 122                  :database-type database-type
 123                  :connection-spec connection-spec
 124                  :errno (PQstatus connection)
 125                  :error (tidy-error-message
 126                          (PQerrorMessage connection))))
 127         (make-instance 'postgresql-database
 128                        :name (database-name-from-spec connection-spec
 129                                                       database-type)
 130                        :connection-spec connection-spec
 131                        :conn-ptr connection)))))
 132
 133
 134 (defmethod database-disconnect ((database postgresql-database))
 135   (PQfinish (database-conn-ptr database))
 136   (setf (database-conn-ptr database) nil)
 137   t)
 138
 139 (defmethod database-query (query-expression (database postgresql-database) types)
 140   (let ((conn-ptr (database-conn-ptr database)))
 141     (declare (type pgsql-conn-def conn-ptr))
 142     (uffi:with-cstring (query-native query-expression)
 143       (let ((result (PQexec conn-ptr query-native)))
 144         (when (uffi:null-pointer-p result)
 145           (error 'clsql-sql-error
 146                  :database database
 147                  :expression query-expression
 148                  :errno nil
 149                  :error (tidy-error-message (PQerrorMessage conn-ptr))))
 150         (unwind-protect
 151             (case (PQresultStatus result)
 152               (#.pgsql-exec-status-type#empty-query
 153                nil)
 154               (#.pgsql-exec-status-type#tuples-ok
 155                (let ((num-fields (PQnfields result)))
 156                  (setq types
 157                    (canonicalize-types types num-fields
 158                                              result))
 159                  (loop for tuple-index from 0 below (PQntuples result)
 160                        collect
 161                        (loop for i from 0 below num-fields
 162                              collect
 163                              (if (zerop (PQgetisnull result tuple-index i))
 164                                  (convert-raw-field
 165                                   (PQgetvalue result tuple-index i)
 166                                   types i)
 167                                  nil)))))
 168               (t
 169                (error 'clsql-sql-error
 170                       :database database
 171                       :expression query-expression
 172                       :errno (PQresultStatus result)
 173                       :error (tidy-error-message
 174                               (PQresultErrorMessage result)))))
 175           (PQclear result))))))
 176
 177 (defmethod database-execute-command (sql-expression
 178                                      (database postgresql-database))
 179   (let ((conn-ptr (database-conn-ptr database)))
 180     (declare (type pgsql-conn-def conn-ptr))
 181     (uffi:with-cstring (sql-native sql-expression)
 182       (let ((result (PQexec conn-ptr sql-native)))
 183         (when (uffi:null-pointer-p result)
 184           (error 'clsql-sql-error
 185                  :database database
 186                  :expression sql-expression
 187                  :errno nil
 188                  :error (tidy-error-message (PQerrorMessage conn-ptr))))
 189         (unwind-protect
 190             (case (PQresultStatus result)
 191               (#.pgsql-exec-status-type#command-ok
 192                t)
 193               ((#.pgsql-exec-status-type#empty-query
 194                 #.pgsql-exec-status-type#tuples-ok)
 195                (warn "Strange result...")
 196                t)
 197               (t
 198                (error 'clsql-sql-error
 199                       :database database
 200                       :expression sql-expression
 201                       :errno (PQresultStatus result)
 202                       :error (tidy-error-message
 203                               (PQresultErrorMessage result)))))
 204           (PQclear result))))))
 205
 206 (defstruct postgresql-result-set
 207   (res-ptr (uffi:make-null-pointer 'pgsql-result)
 208            :type pgsql-result-def)
 209   (types nil)
 210   (num-tuples 0 :type integer)
 211   (num-fields 0 :type integer)
 212   (tuple-index 0 :type integer))
 213
 214 (defmethod database-query-result-set (query-expression (database postgresql-database)
 215                                       &key full-set types)
 216   (let ((conn-ptr (database-conn-ptr database)))
 217     (declare (type pgsql-conn-def conn-ptr))
 218     (uffi:with-cstring (query-native query-expression)
 219       (let ((result (PQexec conn-ptr query-native)))
 220         (when (uffi:null-pointer-p result)
 221           (error 'clsql-sql-error
 222                  :database database
 223                  :expression query-expression
 224                  :errno nil
 225                  :error (tidy-error-message (PQerrorMessage conn-ptr))))
 226         (case (PQresultStatus result)
 227           ((#.pgsql-exec-status-type#empty-query
 228             #.pgsql-exec-status-type#tuples-ok)
 229            (let ((result-set (make-postgresql-result-set
 230                         :res-ptr result
 231                         :num-fields (PQnfields result)
 232                         :num-tuples (PQntuples result)
 233                         :types (canonicalize-types
 234                                       types
 235                                       (PQnfields result)
 236                                       result))))
 237              (if full-set
 238                  (values result-set
 239                          (PQnfields result)
 240                          (PQntuples result))
 241                  (values result-set
 242                          (PQnfields result)))))
 243           (t
 244            (unwind-protect
 245                (error 'clsql-sql-error
 246                       :database database
 247                       :expression query-expression
 248                       :errno (PQresultStatus result)
 249                       :error (tidy-error-message
 250                               (PQresultErrorMessage result)))
 251              (PQclear result))))))))
 252
 253 (defmethod database-dump-result-set (result-set (database postgresql-database))
 254   (let ((res-ptr (postgresql-result-set-res-ptr result-set)))
 255     (declare (type pgsql-result-def res-ptr))
 256     (PQclear res-ptr)
 257     t))
 258
 259 (defmethod database-store-next-row (result-set (database postgresql-database)
 260                                     list)
 261   (let ((result (postgresql-result-set-res-ptr result-set))
 262         (types (postgresql-result-set-types result-set)))
 263     (declare (type pgsql-result-def result))
 264     (if (>= (postgresql-result-set-tuple-index result-set)
 265             (postgresql-result-set-num-tuples result-set))
 266         nil
 267       (loop with tuple-index = (postgresql-result-set-tuple-index result-set)
 268           for i from 0 below (postgresql-result-set-num-fields result-set)
 269           for rest on list
 270           do
 271             (setf (car rest)
 272               (if (zerop (PQgetisnull result tuple-index i))
 273                   (convert-raw-field
 274                    (PQgetvalue result tuple-index i)
 275                    types i)
 276                 nil))
 277           finally
 278             (incf (postgresql-result-set-tuple-index result-set))
 279             (return list)))))
 280
 281 ;;; Large objects support (Marc B)
 282
 283 (defmethod database-create-large-object ((database postgresql-database))
 284   (lo-create (database-conn-ptr database)
 285              (logior postgresql::+INV_WRITE+ postgresql::+INV_READ+)))
 286
 287
 288 #+mb-original
 289 (defmethod database-write-large-object (object-id (data string) (database postgresql-database))
 290   (let ((ptr (database-conn-ptr database))
 291         (length (length data))
 292         (result nil)
 293         (fd nil))
 294     (with-transaction (:database database)
 295        (unwind-protect
 296           (progn
 297             (setf fd (lo-open ptr object-id postgresql::+INV_WRITE+))
 298             (when (>= fd 0)
 299               (when (= (lo-write ptr fd data length) length)
 300                 (setf result t))))
 301          (progn
 302            (when (and fd (>= fd 0))
 303              (lo-close ptr fd))
 304            )))
 305     result))
 306
 307 (defmethod database-write-large-object (object-id (data string) (database postgresql-database))
 308   (let ((ptr (database-conn-ptr database))
 309         (length (length data))
 310         (result nil)
 311         (fd nil))
 312     (database-execute-command "begin" database)
 313     (unwind-protect
 314         (progn
 315           (setf fd (lo-open ptr object-id postgresql::+INV_WRITE+))
 316           (when (>= fd 0)
 317             (when (= (lo-write ptr fd data length) length)
 318               (setf result t))))
 319       (progn
 320         (when (and fd (>= fd 0))
 321           (lo-close ptr fd))
 322         (database-execute-command (if result "commit" "rollback") database)))
 323     result))
 324
 325 ;; (MB) the begin/commit/rollback stuff will be removed when with-transaction wil be implemented
 326 ;; (KMR) Can't use with-transaction since that function is in high-level code
 327 (defmethod database-read-large-object (object-id (database postgresql-database))
 328   (let ((ptr (database-conn-ptr database))
 329         (buffer nil)
 330         (result nil)
 331         (length 0)
 332         (fd nil))
 333     (unwind-protect
 334        (progn
 335          (database-execute-command "begin" database)
 336          (setf fd (lo-open ptr object-id postgresql::+INV_READ+))
 337          (when (>= fd 0)
 338            (setf length (lo-lseek ptr fd 0 2))
 339            (lo-lseek ptr fd 0 0)
 340            (when (> length 0)
 341              (setf buffer (uffi:allocate-foreign-string
 342                            length :unsigned t))
 343              (when (= (lo-read ptr fd buffer length) length)
 344                (setf result (uffi:convert-from-foreign-string
 345                              buffer :length length :null-terminated-p nil))))))
 346       (progn
 347         (when buffer (uffi:free-foreign-object buffer))
 348         (when (and fd (>= fd 0)) (lo-close ptr fd))
 349         (database-execute-command (if result "commit" "rollback") database)))
 350     result))
 351
 352 (defmethod database-delete-large-object (object-id (database postgresql-database))
 353   (lo-unlink (database-conn-ptr database) object-id))
 354
 355 (when (clsql-base-sys:database-type-library-loaded :postgresql)
 356   (clsql-base-sys:initialize-database-type :database-type :postgresql))