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