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         (keyword "unix")
 113         (pathname (namestring host))
 114         (string host))
 115       (when port
 116         (concatenate 'string
 117                      ":"
 118                      (etypecase port
 119                        (integer (write-to-string port))
 120                        (string port))))
 121       "/" db "/" user)))
 122
 123 (defmethod database-connect (connection-spec
 124                              (database-type (eql :postgresql-socket3)))
 125   (check-connection-spec connection-spec database-type
 126                          (host db user password &optional port options tty))
 127   (destructuring-bind (host db user password &optional
 128                             (port +postgresql-server-default-port+)
 129                             (options "") (tty ""))
 130       connection-spec
 131     (declare (ignore options tty))
 132     (handler-case
 133         (handler-bind ((warning
 134                         (lambda (c)
 135                           (warn 'sql-warning
 136                                 :format-control "~A"
 137                                 :format-arguments
 138                                 (list (princ-to-string c))))))
 139           (cl-postgres:open-database db user password host port))
 140       (cl-postgres:database-error (c)
 141         ;; Connect failed
 142         (error 'sql-connection-error
 143                :database-type database-type
 144                :connection-spec connection-spec
 145                :error-id (type-of c)
 146                :message (cl-postgres:database-error-message c)))
 147       (:no-error (connection)
 148                  ;; Success, make instance
 149                  (make-instance 'postgresql-socket3-database
 150                                 :name (database-name-from-spec connection-spec database-type)
 151                                 :database-type :postgresql-socket3
 152                                 :connection-spec connection-spec
 153                                 :connection connection)))))
 154
 155 (defmethod database-disconnect ((database postgresql-socket3-database))
 156   (cl-postgres:close-database (database-connection database))
 157   t)
 158
 159 (defvar *include-field-names* nil)
 160
 161
 162 ;; THE FOLLOWING MACRO EXPANDS TO THE FUNCTION BELOW IT,
 163 ;; BUT TO GET null CONVENTIONS CORRECT I NEEDED TO TWEAK THE EXPANSION
 164 ;;
 165 ;; (cl-postgres:def-row-reader clsql-default-row-reader (fields)
 166 ;;   (values (loop :while (cl-postgres:next-row)
 167 ;;              :collect (loop :for field :across fields
 168 ;;                             :collect (cl-postgres:next-field field)))
 169 ;;        (when *include-field-names*
 170 ;;          (loop :for field :across fields
 171 ;;                :collect (cl-postgres:field-name field)))))
 172
 173
 174
 175 (defun clsql-default-row-reader (stream fields)
 176   (declare (type stream stream)
 177            (type (simple-array cl-postgres::field-description) fields))
 178   (flet ((cl-postgres:next-row ()
 179            (cl-postgres::look-for-row stream))
 180          (cl-postgres:next-field (cl-postgres::field)
 181            (declare (type cl-postgres::field-description cl-postgres::field))
 182            (let ((cl-postgres::size (cl-postgres::read-int4 stream)))
 183              (declare (type (signed-byte 32) cl-postgres::size))
 184              (if (eq cl-postgres::size -1)
 185                  nil
 186                  (funcall (cl-postgres::field-interpreter cl-postgres::field)
 187                           stream cl-postgres::size)))))
 188     (let ((results (loop :while (cl-postgres:next-row)
 189                          :collect (loop :for field :across fields
 190                                         :collect (cl-postgres:next-field field))))
 191           (col-names (when *include-field-names*
 192                        (loop :for field :across fields
 193                              :collect (cl-postgres:field-name field)))))
 194       ;;multiple return values were not working here
 195       (list results col-names))))
 196
 197 (defmethod database-query ((expression string) (database postgresql-socket3-database) result-types field-names)
 198   (let ((connection (database-connection database))
 199         (cl-postgres:*sql-readtable* *sqlreader*))
 200     (with-postgresql-handlers (database expression)
 201       (let ((*include-field-names* field-names))
 202         (apply #'values (cl-postgres:exec-query connection expression #'clsql-default-row-reader)))
 203       )))
 204
 205 (defmethod query ((obj command-object) &key (database *default-database*)
 206                   (result-types :auto) (flatp nil) (field-names t))
 207   (clsql-sys::record-sql-command
 208    (format nil "~&~A~&{Params: ~{~A~^, ~}}"
 209            (expression obj)
 210            (parameters obj))
 211    database)
 212   (multiple-value-bind (rows names)
 213       (database-query obj database result-types field-names)
 214     (let ((result (if (and flatp (= 1 (length (car rows))))
 215                       (mapcar #'car rows)
 216                       rows)))
 217       (clsql-sys::record-sql-result result database)
 218       (if field-names
 219           (values result names)
 220           result))))
 221
 222 (defmethod database-query ((obj command-object) (database postgresql-socket3-database) result-types field-names)
 223   (let ((connection (database-connection database))
 224         (cl-postgres:*sql-readtable* *sqlreader*))
 225     (with-postgresql-handlers (database obj)
 226       (let ((*include-field-names* field-names))
 227         (unless (has-been-prepared obj)
 228           (cl-postgres:prepare-query connection (prepared-name obj) (expression obj))
 229           (setf (has-been-prepared obj) T))
 230         (apply #'values (cl-postgres:exec-prepared
 231                          connection
 232                          (prepared-name obj)
 233                          (parameters obj)
 234                          #'clsql-default-row-reader))))))
 235
 236 (defmethod database-execute-command
 237     ((expression string) (database postgresql-socket3-database))
 238   (let ((connection (database-connection database)))
 239     (with-postgresql-handlers (database expression)
 240       ;; return row count?
 241       (second (multiple-value-list (cl-postgres:exec-query connection expression))))))
 242
 243 (defmethod execute-command ((obj command-object)
 244                             &key (database *default-database*))
 245   (clsql-sys::record-sql-command (expression obj) database)
 246   (let ((res (database-execute-command obj database)))
 247     (clsql-sys::record-sql-result res database)
 248     ;; return row count?
 249     res))
 250
 251 (defmethod database-execute-command
 252     ((obj command-object) (database postgresql-socket3-database))
 253   (let ((connection (database-connection database)))
 254     (with-postgresql-handlers (database obj)
 255       (unless (has-been-prepared obj)
 256         (cl-postgres:prepare-query connection (prepared-name obj) (expression obj))
 257         (setf (has-been-prepared obj) T))
 258       (second (multiple-value-list (cl-postgres:exec-prepared connection (prepared-name obj) (parameters obj)))))))
 259
 260 ;;;; Cursoring interface
 261
 262
 263 (defmethod database-query-result-set ((expression string)
 264                                       (database postgresql-socket3-database)
 265                                       &key full-set result-types)
 266   (declare (ignore result-types))
 267   (declare (ignore full-set))
 268   (error "Cursoring interface is not supported for postgresql-socket3-database try cl-postgres:exec-query with a custom row-reader"))
 269
 270 (defmethod database-dump-result-set (result-set
 271                                      (database postgresql-socket3-database))
 272   (error "Cursoring interface is not supported for postgresql-socket3-database try cl-postgres:exec-query with a custom row-reader")
 273   T)
 274
 275 (defmethod database-store-next-row (result-set
 276                                     (database postgresql-socket3-database)
 277                                     list)
 278   (error "Cursoring interface is not supported for postgresql-socket3-database try cl-postgres:exec-query with a custom row-reader"))
 279
 280
 281 ;;;;;;;;;;;;;;;;;;;;;;;;;;
 282
 283
 284 (defmethod database-create (connection-spec (type (eql :postgresql-socket3)))
 285   (destructuring-bind (host name user password &optional port options tty) connection-spec
 286     (declare (ignore port options tty))
 287     (let ((database (database-connect (list host "postgres" user password)
 288                                       type)))
 289       (setf (slot-value database 'clsql-sys::state) :open)
 290       (unwind-protect
 291            (database-execute-command (format nil "create database ~A" name) database)
 292         (database-disconnect database)))))
 293
 294 (defmethod database-destroy (connection-spec (type (eql :postgresql-socket3)))
 295   (destructuring-bind (host name user password &optional port options tty) connection-spec
 296     (declare (ignore port options tty))
 297     (let ((database (database-connect (list host "postgres" user password)
 298                                       type)))
 299       (setf (slot-value database 'clsql-sys::state) :open)
 300       (unwind-protect
 301           (database-execute-command (format nil "drop database ~A" name) database)
 302         (database-disconnect database)))))
 303
 304
 305 (defmethod database-probe (connection-spec (type (eql :postgresql-socket3)))
 306   (when (find (second connection-spec) (database-list connection-spec type)
 307               :test #'string-equal)
 308     t))
 309
 310
 311 ;; Database capabilities
 312
 313 (defmethod db-backend-has-create/destroy-db? ((db-type (eql :postgresql-socket3)))
 314   nil)
 315
 316 (defmethod db-type-has-fancy-math? ((db-type (eql :postgresql-socket3)))
 317   t)
 318
 319 (defmethod db-type-default-case ((db-type (eql :postgresql-socket3)))
 320   :lower)
 321
 322 (defmethod database-underlying-type ((database postgresql-socket3-database))
 323   :postgresql)
 324
 325 (when (clsql-sys:database-type-library-loaded :postgresql-socket3)
 326   (clsql-sys:initialize-database-type :database-type :postgresql-socket3))
 327
 328