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-2004 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-socket
23 (:use
#:common-lisp
#:clsql-sys
#:postgresql-socket
)
24 (:export
#:postgresql-socket-database
)
25 (:documentation
"This is the CLSQL socket interface to PostgreSQL."))
27 (in-package #:clsql-postgresql-socket
)
29 ;; interface foreign library loading routines
32 (clsql-sys:database-type-load-foreign
:postgresql-socket
)
35 ;; Field type conversion
37 (defun make-type-list-for-auto (cursor)
38 (let* ((fields (postgresql-cursor-fields cursor
))
39 (num-fields (length fields
))
41 (dotimes (i num-fields
)
43 (push (canonical-field-type fields i
) new-types
))
44 (nreverse new-types
)))
46 (defun canonical-field-type (fields index
)
47 "Extracts canonical field type from fields list"
48 (let ((oid (cadr (nth index fields
))))
56 ((#.pgsql-ftype
#float4
62 (defun canonicalize-types (types cursor
)
65 (let ((auto-list (make-type-list-for-auto cursor
)))
68 (canonicalize-type-list types auto-list
))
74 (defun canonicalize-type-list (types auto-list
)
75 "Ensure a field type list meets expectations.
76 Duplicated from clsql-uffi package so that this interface
77 doesn't depend on UFFI."
78 (let ((length-types (length types
))
80 (loop for i from
0 below
(length auto-list
)
82 (if (>= i length-types
)
83 (push t new-types
) ;; types is shorted than num-fields
87 (case (nth i auto-list
)
95 (case (nth i auto-list
)
103 (nreverse new-types
)))
106 (defun convert-to-clsql-warning (database condition
)
107 (ecase *backend-warning-behavior
*
109 (warn 'sql-database-warning
:database database
110 :message
(postgresql-condition-message condition
)))
112 (error 'sql-database-error
:database database
113 :message
(format nil
"Warning upgraded to error: ~A"
114 (postgresql-condition-message condition
))))
119 (defun convert-to-clsql-error (database expression condition
)
120 (error 'sql-database-data-error
122 :expression expression
123 :error-id
(type-of condition
)
124 :message
(postgresql-condition-message condition
)))
126 (defmacro with-postgresql-handlers
127 ((database &optional expression
)
129 (let ((database-var (gensym))
130 (expression-var (gensym)))
131 `(let ((,database-var
,database
)
132 (,expression-var
,expression
))
133 (handler-bind ((postgresql-warning
135 (convert-to-clsql-warning ,database-var c
)))
138 (convert-to-clsql-error
139 ,database-var
,expression-var c
))))
142 (defmethod database-initialize-database-type ((database-type
143 (eql :postgresql-socket
)))
146 (defclass postgresql-socket-database
(generic-postgresql-database)
147 ((connection :accessor database-connection
:initarg
:connection
148 :type postgresql-connection
)))
150 (defmethod database-type ((database postgresql-socket-database
))
153 (defmethod database-name-from-spec (connection-spec
154 (database-type (eql :postgresql-socket
)))
155 (check-connection-spec connection-spec database-type
156 (host db user password
&optional port options tty
))
157 (destructuring-bind (host db user password
&optional port options tty
)
159 (declare (ignore password options tty
))
164 (pathname (namestring host
))
170 (integer (write-to-string port
))
174 (defmethod database-connect (connection-spec
175 (database-type (eql :postgresql-socket
)))
176 (check-connection-spec connection-spec database-type
177 (host db user password
&optional port options tty
))
178 (destructuring-bind (host db user password
&optional
179 (port +postgresql-server-default-port
+)
180 (options "") (tty ""))
183 (handler-bind ((postgresql-warning
188 (list (princ-to-string c
))))))
189 (open-postgresql-connection :host host
:port port
190 :options options
:tty tty
191 :database db
:user user
193 (postgresql-error (c)
195 (error 'sql-connection-error
196 :database-type database-type
197 :connection-spec connection-spec
198 :error-id
(type-of c
)
199 :message
(postgresql-condition-message c
)))
200 (:no-error
(connection)
201 ;; Success, make instance
202 (make-instance 'postgresql-socket-database
203 :name
(database-name-from-spec connection-spec
205 :database-type
:postgresql-socket
206 :connection-spec connection-spec
207 :connection connection
)))))
209 (defmethod database-disconnect ((database postgresql-socket-database
))
210 (close-postgresql-connection (database-connection database
))
213 (defmethod database-query (expression (database postgresql-socket-database
) result-types field-names
)
214 (let ((connection (database-connection database
)))
215 (with-postgresql-handlers (database expression
)
216 (start-query-execution connection expression
)
217 (multiple-value-bind (status cursor
)
218 (wait-for-query-results connection
)
219 (unless (eq status
:cursor
)
220 (close-postgresql-connection connection
)
221 (error 'sql-database-data-error
223 :expression expression
224 :error-id
"missing-result"
225 :message
"Didn't receive result cursor for query."))
226 (setq result-types
(canonicalize-types result-types cursor
))
228 (loop for row
= (read-cursor-row cursor result-types
)
232 (unless (null (wait-for-query-results connection
))
233 (close-postgresql-connection connection
)
234 (error 'sql-database-data-error
236 :expression expression
237 :error-id
"multiple-results"
238 :message
"Received multiple results for query.")))
240 (mapcar #'car
(postgresql-cursor-fields cursor
))))))))
242 (defmethod database-execute-command
243 (expression (database postgresql-socket-database
))
244 (let ((connection (database-connection database
)))
245 (with-postgresql-handlers (database expression
)
246 (start-query-execution connection expression
)
247 (multiple-value-bind (status result
)
248 (wait-for-query-results connection
)
249 (when (eq status
:cursor
)
251 (multiple-value-bind (row stuff
)
252 (skip-cursor-row result
)
254 (setq status
:completed result stuff
)
259 ((eq status
:completed
)
260 (unless (null (wait-for-query-results connection
))
261 (close-postgresql-connection connection
)
262 (error 'sql-database-data-error
264 :expression expression
265 :error-id
"multiple-results"
266 :message
"Received multiple results for command."))
269 (close-postgresql-connection connection
)
270 (error 'sql-database-data-error
272 :expression expression
273 :errno
"missing-result"
274 :message
"Didn't receive completion for command.")))))))
276 (defstruct postgresql-socket-result-set
281 (defmethod database-query-result-set ((expression string
)
282 (database postgresql-socket-database
)
283 &key full-set result-types
)
284 (declare (ignore full-set
))
285 (let ((connection (database-connection database
)))
286 (with-postgresql-handlers (database expression
)
287 (start-query-execution connection expression
)
288 (multiple-value-bind (status cursor
)
289 (wait-for-query-results connection
)
290 (unless (eq status
:cursor
)
291 (close-postgresql-connection connection
)
292 (error 'sql-database-data-error
294 :expression expression
295 :error-id
"missing-result"
296 :message
"Didn't receive result cursor for query."))
297 (values (make-postgresql-socket-result-set
300 :types
(canonicalize-types result-types cursor
))
301 (length (postgresql-cursor-fields cursor
)))))))
303 (defmethod database-dump-result-set (result-set
304 (database postgresql-socket-database
))
305 (if (postgresql-socket-result-set-done result-set
)
307 (with-postgresql-handlers (database)
308 (loop while
(skip-cursor-row
309 (postgresql-socket-result-set-cursor result-set
))
310 finally
(setf (postgresql-socket-result-set-done result-set
) t
)))))
312 (defmethod database-store-next-row (result-set
313 (database postgresql-socket-database
)
315 (let ((cursor (postgresql-socket-result-set-cursor result-set
)))
316 (with-postgresql-handlers (database)
317 (if (copy-cursor-row cursor
319 (postgresql-socket-result-set-types
323 (setf (postgresql-socket-result-set-done result-set
) t
)
324 (wait-for-query-results (database-connection database
)))))))
326 (defmethod database-create (connection-spec (type (eql :postgresql-socket
)))
327 (destructuring-bind (host name user password
) connection-spec
328 (let ((database (database-connect (list host
"template1" user password
)
331 (execute-command (format nil
"create database ~A" name
))
332 (database-disconnect database
)))))
334 (defmethod database-destroy (connection-spec (type (eql :postgresql-socket
)))
335 (destructuring-bind (host name user password
) connection-spec
336 (let ((database (database-connect (list host
"template1" user password
)
339 (execute-command (format nil
"drop database ~A" name
))
340 (database-disconnect database
)))))
343 (defmethod database-probe (connection-spec (type (eql :postgresql-socket
)))
344 (when (find (second connection-spec
) (database-list connection-spec type
)
345 :test
#'string-equal
)
349 ;; Database capabilities
351 (defmethod db-backend-has-create/destroy-db?
((db-type (eql :postgresql-socket
)))
354 (defmethod db-type-has-fancy-math?
((db-type (eql :postgresql-socket
)))
357 (defmethod db-type-default-case ((db-type (eql :postgresql-socket
)))
360 (defmethod database-underlying-type ((database postgresql-socket-database
))
363 (when (clsql-sys:database-type-library-loaded
:postgresql-socket
)
364 (clsql-sys:initialize-database-type
:database-type
:postgresql-socket
))