db-postgresql-socket3/sql.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:     postgresql-socket-sql.sql
   6 ;;;; Purpose:  High-level PostgreSQL interface using socket
   7 ;;;; Authors:  Kevin M. Rosenberg based on original code by Pierre R. Mai
   8 ;;;; Created:  Feb 2002
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of CLSQL, is Copyright (c) 2002-2007 by Kevin M. Rosenberg
  13 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
  14 ;;;;
  15 ;;;; CLSQL users are granted the rights to distribute and use this software
  16 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  17 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  18 ;;;; *************************************************************************
  19
  20 (in-package #:cl-user)
  21
  22 (defpackage :clsql-postgresql-socket3
  23     (:use #:common-lisp #:clsql-sys #:postgresql-socket3)
  24     (:export #:postgresql-socket3-database)
  25     (:documentation
  26      "This is the CLSQL socket interface (protocol version 3) to PostgreSQL."))
  27
  28 (in-package #:clsql-postgresql-socket3)
  29
  30 (defvar *sqlreader* (cl-postgres:copy-sql-readtable))
  31
  32
  33 (labels ((d-fn (days-since-2000)
  34            (clsql:make-date :year 2000 :day (+ 1 days-since-2000)))
  35          (dt-tz-fn (useconds-since-2000
  36                     &aux (dt (dt-fn useconds-since-2000)))
  37            (setf (clsql-sys::time-is-utc? dt) t)
  38            dt)
  39          (dt-fn (useconds-since-2000)
  40            (multiple-value-bind (sec usec)
  41                (floor useconds-since-2000 1000000)
  42              (clsql:make-time :year 2000 :second sec :usec usec))))
  43   (cl-postgres:set-sql-datetime-readers
  44    :table *sqlreader*
  45    :timestamp #'dt-fn
  46    :timestamp-with-timezone #'dt-tz-fn
  47    :date #'d-fn))
  48
  49
  50
  51 ;; interface foreign library loading routines
  52
  53 (clsql-sys:database-type-load-foreign :postgresql-socket3)
  54
  55
  56 (defmethod database-initialize-database-type ((database-type
  57                                                (eql :postgresql-socket3)))
  58   t)
  59
  60
  61 ;; Field type conversion
  62 (defun convert-to-clsql-warning (database condition)
  63   (ecase *backend-warning-behavior*
  64     (:warn
  65      (warn 'sql-database-warning :database database
  66            :message (cl-postgres:database-error-message condition)))
  67     (:error
  68      (error 'sql-database-error :database database
  69             :message (format nil "Warning upgraded to error: ~A"
  70                              (cl-postgres:database-error-message condition))))
  71     ((:ignore nil)
  72      ;; do nothing
  73      )))
  74
  75 (defun convert-to-clsql-error (database expression condition)
  76   (error 'sql-database-data-error
  77          :database database
  78          :expression expression
  79          :error-id (type-of condition)
  80          :message (cl-postgres:database-error-message condition)))
  81
  82 (defmacro with-postgresql-handlers
  83     ((database &optional expression)
  84      &body body)
  85   (let ((database-var (gensym))
  86         (expression-var (gensym)))
  87     `(let ((,database-var ,database)
  88            (,expression-var ,expression))
  89        (handler-bind ((postgresql-warning
  90                        (lambda (c)
  91                          (convert-to-clsql-warning ,database-var c)))
  92                       (cl-postgres:database-error
  93                        (lambda (c)
  94                          (convert-to-clsql-error
  95                           ,database-var ,expression-var c))))
  96          ,@body))))
  97
  98
  99
 100 (defclass postgresql-socket3-database (generic-postgresql-database)
 101   ((connection :accessor database-connection :initarg :connection
 102                :type cl-postgres:database-connection)))
 103
 104 (defmethod database-type ((database postgresql-socket3-database))
 105   :postgresql-socket3)
 106
 107 (defmethod database-name-from-spec (connection-spec (database-type (eql :postgresql-socket3)))
 108   (check-connection-spec connection-spec database-type
 109                          (host db user password &optional port options tty))
 110   (destructuring-bind (host db user password &optional port options tty)
 111       connection-spec
 112     (declare (ignore password options tty))
 113     (concatenate 'string
 114       (etypecase host
 115         (null
 116          "localhost")
 117         (keyword "unix")
 118         (pathname (namestring host))
 119         (string host))
 120       (when port
 121         (concatenate 'string
 122                      ":"
 123                      (etypecase port
 124                        (integer (write-to-string port))
 125                        (string port))))
 126       "/" db "/" user)))
 127
 128 (defmethod database-connect (connection-spec
 129                              (database-type (eql :postgresql-socket3)))
 130   (check-connection-spec connection-spec database-type
 131                          (host db user password &optional port options tty))
 132   (destructuring-bind (host db user password &optional
 133                             (port +postgresql-server-default-port+)
 134                             (options "") (tty ""))
 135       connection-spec
 136     (declare (ignore options tty))
 137     (handler-case
 138         (handler-bind ((warning
 139                         (lambda (c)
 140                           (warn 'sql-warning
 141                                 :format-control "~A"
 142                                 :format-arguments
 143                                 (list (princ-to-string c))))))
 144           (cl-postgres:open-database db user password host port))
 145       (cl-postgres:database-error (c)
 146         ;; Connect failed
 147         (error 'sql-connection-error
 148                :database-type database-type
 149                :connection-spec connection-spec
 150                :error-id (type-of c)
 151                :message (cl-postgres:database-error-message c)))
 152       (:no-error (connection)
 153                  ;; Success, make instance
 154                  (make-instance 'postgresql-socket3-database
 155                                 :name (database-name-from-spec connection-spec database-type)
 156                                 :database-type :postgresql-socket3
 157                                 :connection-spec connection-spec
 158                                 :connection connection)))))
 159
 160 (defmethod database-disconnect ((database postgresql-socket3-database))
 161   (cl-postgres:close-database (database-connection database))
 162   t)
 163
 164 (defvar *include-field-names* nil)
 165
 166
 167 ;; THE FOLLOWING MACRO EXPANDS TO THE FUNCTION BELOW IT,
 168 ;; BUT TO GET null CONVENTIONS CORRECT I NEEDED TO TWEAK THE EXPANSION
 169 ;;
 170 ;; (cl-postgres:def-row-reader clsql-default-row-reader (fields)
 171 ;;   (values (loop :while (cl-postgres:next-row)
 172 ;;              :collect (loop :for field :across fields
 173 ;;                             :collect (cl-postgres:next-field field)))
 174 ;;        (when *include-field-names*
 175 ;;          (loop :for field :across fields
 176 ;;                :collect (cl-postgres:field-name field)))))
 177
 178
 179
 180 (defun clsql-default-row-reader (stream fields)
 181   (declare (type stream stream)
 182            (type (simple-array cl-postgres::field-description) fields))
 183   (flet ((cl-postgres:next-row ()
 184            (cl-postgres::look-for-row stream))
 185          (cl-postgres:next-field (cl-postgres::field)
 186            (declare (type cl-postgres::field-description cl-postgres::field))
 187            (let ((cl-postgres::size (cl-postgres::read-int4 stream)))
 188              (declare (type (signed-byte 32) cl-postgres::size))
 189              (if (eq cl-postgres::size -1)
 190                  nil
 191                  (funcall (cl-postgres::field-interpreter cl-postgres::field)
 192                           stream cl-postgres::size)))))
 193     (let ((results (loop :while (cl-postgres:next-row)
 194                          :collect (loop :for field :across fields
 195                                         :collect (cl-postgres:next-field field))))
 196           (col-names (when *include-field-names*
 197                        (loop :for field :across fields
 198                              :collect (cl-postgres:field-name field)))))
 199       ;;multiple return values were not working here
 200       (list results col-names))))
 201
 202 (defmethod database-query ((expression string) (database postgresql-socket3-database) result-types field-names)
 203   (let ((connection (database-connection database))
 204         (cl-postgres:*sql-readtable* *sqlreader*))
 205     (with-postgresql-handlers (database expression)
 206       (let ((*include-field-names* field-names))
 207         (apply #'values (cl-postgres:exec-query connection expression #'clsql-default-row-reader)))
 208       )))
 209
 210 (defmethod query ((obj command-object) &key (database *default-database*)
 211                   (result-types :auto) (flatp nil) (field-names t))
 212   (clsql-sys::record-sql-command
 213    (format nil "~&~A~&{Params: ~{~A~^, ~}}"
 214            (expression obj)
 215            (parameters obj))
 216    database)
 217   (multiple-value-bind (rows names)
 218       (database-query obj database result-types field-names)
 219     (let ((result (if (and flatp (= 1 (length (car rows))))
 220                       (mapcar #'car rows)
 221                       rows)))
 222       (clsql-sys::record-sql-result result database)
 223       (if field-names
 224           (values result names)
 225           result))))
 226
 227 (defmethod database-query ((obj command-object) (database postgresql-socket3-database) result-types field-names)
 228   (let ((connection (database-connection database))
 229         (cl-postgres:*sql-readtable* *sqlreader*))
 230     (with-postgresql-handlers (database obj)
 231       (let ((*include-field-names* field-names))
 232         (unless (has-been-prepared obj)
 233           (cl-postgres:prepare-query connection (prepared-name obj) (expression obj))
 234           (setf (has-been-prepared obj) T))
 235         (apply #'values (cl-postgres:exec-prepared
 236                          connection
 237                          (prepared-name obj)
 238                          (parameters obj)
 239                          #'clsql-default-row-reader))))))
 240
 241 (defmethod database-execute-command
 242     ((expression string) (database postgresql-socket3-database))
 243   (let ((connection (database-connection database)))
 244     (with-postgresql-handlers (database expression)
 245       ;; return row count?
 246       (second (multiple-value-list (cl-postgres:exec-query connection expression))))))
 247
 248 (defmethod execute-command ((obj command-object)
 249                             &key (database *default-database*))
 250   (clsql-sys::record-sql-command (expression obj) database)
 251   (let ((res (database-execute-command obj database)))
 252     (clsql-sys::record-sql-result res database)
 253     ;; return row count?
 254     res))
 255
 256 (defmethod database-execute-command
 257     ((obj command-object) (database postgresql-socket3-database))
 258   (let ((connection (database-connection database)))
 259     (with-postgresql-handlers (database obj)
 260       (unless (has-been-prepared obj)
 261         (cl-postgres:prepare-query connection (prepared-name obj) (expression obj))
 262         (setf (has-been-prepared obj) T))
 263       (second (multiple-value-list (cl-postgres:exec-prepared connection (prepared-name obj) (parameters obj)))))))
 264
 265 ;;;; Cursoring interface
 266
 267
 268 (defmethod database-query-result-set ((expression string)
 269                                       (database postgresql-socket3-database)
 270                                       &key full-set result-types)
 271   (declare (ignore result-types))
 272   (declare (ignore full-set))
 273   (error "Cursoring interface is not supported for postgresql-socket3-database try cl-postgres:exec-query with a custom row-reader"))
 274
 275 (defmethod database-dump-result-set (result-set
 276                                      (database postgresql-socket3-database))
 277   (error "Cursoring interface is not supported for postgresql-socket3-database try cl-postgres:exec-query with a custom row-reader")
 278   T)
 279
 280 (defmethod database-store-next-row (result-set
 281                                     (database postgresql-socket3-database)
 282                                     list)
 283   (error "Cursoring interface is not supported for postgresql-socket3-database try cl-postgres:exec-query with a custom row-reader"))
 284
 285
 286 ;;;;;;;;;;;;;;;;;;;;;;;;;;
 287
 288
 289 (defmethod database-create (connection-spec (type (eql :postgresql-socket3)))
 290   (destructuring-bind (host name user password &optional port options tty) connection-spec
 291     (declare (ignore port options tty))
 292     (let ((database (database-connect (list host "postgres" user password)
 293                                       type)))
 294       (setf (slot-value database 'clsql-sys::state) :open)
 295       (unwind-protect
 296            (database-execute-command (format nil "create database ~A" name) database)
 297         (database-disconnect database)))))
 298
 299 (defmethod database-destroy (connection-spec (type (eql :postgresql-socket3)))
 300   (destructuring-bind (host name user password &optional port options tty) connection-spec
 301     (declare (ignore port options tty))
 302     (let ((database (database-connect (list host "postgres" user password)
 303                                       type)))
 304       (setf (slot-value database 'clsql-sys::state) :open)
 305       (unwind-protect
 306           (database-execute-command (format nil "drop database ~A" name) database)
 307         (database-disconnect database)))))
 308
 309
 310 (defmethod database-probe (connection-spec (type (eql :postgresql-socket3)))
 311   (when (find (second connection-spec) (database-list connection-spec type)
 312               :test #'string-equal)
 313     t))
 314
 315
 316 ;; Database capabilities
 317
 318 (defmethod db-backend-has-create/destroy-db? ((db-type (eql :postgresql-socket3)))
 319   nil)
 320
 321 (defmethod db-type-has-fancy-math? ((db-type (eql :postgresql-socket3)))
 322   t)
 323
 324 (defmethod db-type-default-case ((db-type (eql :postgresql-socket3)))
 325   :lower)
 326
 327 (defmethod database-underlying-type ((database postgresql-socket3-database))
 328   :postgresql)
 329
 330 (when (clsql-sys:database-type-library-loaded :postgresql-socket3)
 331   (clsql-sys:initialize-database-type :database-type :postgresql-socket3))
 332
 333