1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
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
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
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 ;;;; *************************************************************************
20 (in-package #:cl-user)
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."))
27 (in-package #:clsql-postgresql-socket3)
29 (defvar *sqlreader* (cl-postgres:copy-sql-readtable))
30 (let ((dt-fn (lambda (useconds-since-2000)
32 (/ useconds-since-2000
34 (usec (mod useconds-since-2000
36 (clsql:make-time :year 2000 :second sec :usec usec)))))
37 (cl-postgres:set-sql-datetime-readers
39 :date (lambda (days-since-2000)
40 (clsql:make-date :year 2000 :day (+ 1 days-since-2000)))
42 :timestamp-with-timezone dt-fn))
46 ;; interface foreign library loading routines
48 (clsql-sys:database-type-load-foreign :postgresql-socket3)
51 (defmethod database-initialize-database-type ((database-type
52 (eql :postgresql-socket3)))
56 ;; Field type conversion
57 (defun convert-to-clsql-warning (database condition)
58 (ecase *backend-warning-behavior*
60 (warn 'sql-database-warning :database database
61 :message (postgresql-condition-message condition)))
63 (error 'sql-database-error :database database
64 :message (format nil "Warning upgraded to error: ~A"
65 (postgresql-condition-message condition))))
70 (defun convert-to-clsql-error (database expression condition)
71 (error 'sql-database-data-error
73 :expression expression
74 :error-id (type-of condition)
75 :message (postgresql-condition-message condition)))
77 (defmacro with-postgresql-handlers
78 ((database &optional expression)
80 (let ((database-var (gensym))
81 (expression-var (gensym)))
82 `(let ((,database-var ,database)
83 (,expression-var ,expression))
84 (handler-bind ((postgresql-warning
86 (convert-to-clsql-warning ,database-var c)))
89 (convert-to-clsql-error
90 ,database-var ,expression-var c))))
95 (defclass postgresql-socket3-database (generic-postgresql-database)
96 ((connection :accessor database-connection :initarg :connection
97 :type cl-postgres:database-connection)))
99 (defmethod database-type ((database postgresql-socket3-database))
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)
107 (declare (ignore password options tty))
112 (pathname (namestring host))
118 (integer (write-to-string port))
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 ""))
130 (declare (ignore options tty))
132 (handler-bind ((warning
137 (list (princ-to-string c))))))
138 (cl-postgres:open-database db user password host port))
139 (cl-postgres:database-error (c)
141 (error 'sql-connection-error
142 :database-type database-type
143 :connection-spec connection-spec
144 :error-id (type-of c)
145 :message (postgresql-condition-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)))))
154 (defmethod database-disconnect ((database postgresql-socket3-database))
155 (cl-postgres:close-database (database-connection database))
158 (defvar *include-field-names* nil)
161 ;; THE FOLLOWING MACRO EXPANDS TO THE FUNCTION BELOW IT,
162 ;; BUT TO GET null CONVENTIONS CORRECT I NEEDED TO TWEAK THE EXPANSION
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)))))
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)
185 (funcall (cl-postgres::field-interpreter cl-postgres::field)
186 stream cl-postgres::size)))))
188 (loop :while (cl-postgres:next-row)
189 :collect (loop :for field :across fields
190 :collect (cl-postgres:next-field field)))
191 (when *include-field-names*
192 (loop :for field :across fields
193 :collect (cl-postgres:field-name field))))))
195 (defmethod database-query ((expression string) (database postgresql-socket3-database) result-types field-names)
196 (let ((connection (database-connection database))
197 (cl-postgres:*sql-readtable* *sqlreader*))
198 (with-postgresql-handlers (database expression)
199 (let ((*include-field-names* field-names))
200 (cl-postgres:exec-query connection expression #'clsql-default-row-reader))
203 (defmethod database-execute-command
204 ((expression string) (database postgresql-socket3-database))
205 (let ((connection (database-connection database)))
206 (with-postgresql-handlers (database expression)
207 (cl-postgres:exec-query connection expression))))
209 ;;;; Cursoring interface
212 ((next-row :accessor next-row :initarg :next-row :initform nil)
213 (fields :accessor fields :initarg :fields :initform nil)
214 (next-field :accessor next-field :initarg :next-field :initform nil)
215 (done :accessor done :initarg :done :initform nil)))
219 (cl-postgres:def-row-reader clsql-cursored-row-reader (fields)
221 (make-instance 'cursor
222 :next-row #'cl-postgres:next-row
224 :next-field #'cl-postgres:next-field)))
226 (defmethod database-query-result-set ((expression string)
227 (database postgresql-socket3-database)
228 &key full-set result-types)
229 (declare (ignore result-types))
230 (declare (ignore full-set))
231 (let ((connection (database-connection database))
233 (with-postgresql-handlers (database expression)
234 (cl-postgres:exec-query connection expression 'clsql-cursored-row-reader)
235 (break "Built cursor")
236 (values *cursor* (length (fields *cursor*))))))
238 (defmethod database-dump-result-set (result-set
239 (database postgresql-socket3-database))
240 (unless (done result-set)
241 (loop :while (funcall (next-row result-set))))
244 (defmethod database-store-next-row (result-set
245 (database postgresql-socket3-database)
247 (when (and (not (done result-set))
248 (setf (done result-set) (funcall (next-row result-set))))
249 (let* ((data (loop :for field :across (fields result-set)
250 :collect (funcall (next-field result-set) field))))
253 (setf (car list) (car data) (cdr list) (cdr data))
257 ;;;;;;;;;;;;;;;;;;;;;;;;;;
260 (defmethod database-create (connection-spec (type (eql :postgresql-socket3)))
261 (destructuring-bind (host name user password &optional port options tty) connection-spec
262 (declare (ignore port options tty))
263 (let ((database (database-connect (list host "postgres" user password)
265 (setf (slot-value database 'clsql-sys::state) :open)
267 (database-execute-command (format nil "create database ~A" name) database)
268 (database-disconnect database)))))
270 (defmethod database-destroy (connection-spec (type (eql :postgresql-socket3)))
271 (destructuring-bind (host name user password &optional port options tty) connection-spec
272 (declare (ignore port options tty))
273 (let ((database (database-connect (list host "postgres" user password)
275 (setf (slot-value database 'clsql-sys::state) :open)
277 (database-execute-command (format nil "drop database ~A" name) database)
278 (database-disconnect database)))))
281 (defmethod database-probe (connection-spec (type (eql :postgresql-socket3)))
282 (when (find (second connection-spec) (database-list connection-spec type)
283 :test #'string-equal)
287 ;; Database capabilities
289 (defmethod db-backend-has-create/destroy-db? ((db-type (eql :postgresql-socket3)))
292 (defmethod db-type-has-fancy-math? ((db-type (eql :postgresql-socket3)))
295 (defmethod db-type-default-case ((db-type (eql :postgresql-socket3)))
298 (defmethod database-underlying-type ((database postgresql-socket3-database))
301 (when (clsql-sys:database-type-library-loaded :postgresql-socket3)
302 (clsql-sys:initialize-database-type :database-type :postgresql-socket3))