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