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
10 ;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 by Kevin M. Rosenberg
11 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
13 ;;;; CLSQL users are granted the rights to distribute and use this software
14 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
15 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
16 ;;;; *************************************************************************
18 (in-package #:cl-user)
20 (defpackage :clsql-postgresql-socket
21 (:use #:common-lisp #:clsql-sys #:postgresql-socket)
22 (:export #:postgresql-socket-database)
23 (:documentation "This is the CLSQL socket interface to PostgreSQL."))
25 (in-package #:clsql-postgresql-socket)
27 ;; interface foreign library loading routines
30 (clsql-sys:database-type-load-foreign :postgresql-socket)
33 ;; Field type conversion
35 (defun make-type-list-for-auto (cursor)
36 (let* ((fields (postgresql-cursor-fields cursor))
37 (num-fields (length fields))
39 (dotimes (i num-fields)
41 (push (canonical-field-type fields i) new-types))
42 (nreverse new-types)))
44 (defun canonical-field-type (fields index)
45 "Extracts canonical field type from fields list"
46 (let ((oid (cadr (nth index fields))))
54 ((#.pgsql-ftype#float4
60 (defun canonicalize-types (types cursor)
63 (let ((auto-list (make-type-list-for-auto cursor)))
66 (canonicalize-type-list types auto-list))
72 (defun canonicalize-type-list (types auto-list)
73 "Ensure a field type list meets expectations.
74 Duplicated from clsql-uffi package so that this interface
75 doesn't depend on UFFI."
76 (let ((length-types (length types))
78 (loop for i from 0 below (length auto-list)
80 (if (>= i length-types)
81 (push t new-types) ;; types is shorted than num-fields
85 (case (nth i auto-list)
93 (case (nth i auto-list)
101 (nreverse new-types)))
104 (defun convert-to-clsql-warning (database condition)
105 (ecase *backend-warning-behavior*
107 (warn 'sql-database-warning :database database
108 :message (postgresql-condition-message condition)))
110 (error 'sql-database-error :database database
111 :message (format nil "Warning upgraded to error: ~A"
112 (postgresql-condition-message condition))))
117 (defun convert-to-clsql-error (database expression condition)
118 (error 'sql-database-data-error
120 :expression expression
121 :error-id (type-of condition)
122 :message (postgresql-condition-message condition)))
124 (defmacro with-postgresql-handlers
125 ((database &optional expression)
127 (let ((database-var (gensym))
128 (expression-var (gensym)))
129 `(let ((,database-var ,database)
130 (,expression-var ,expression))
131 (handler-bind ((postgresql-warning
133 (convert-to-clsql-warning ,database-var c)))
136 (convert-to-clsql-error
137 ,database-var ,expression-var c))))
140 (defmethod database-initialize-database-type ((database-type
141 (eql :postgresql-socket)))
144 (defclass postgresql-socket-database (generic-postgresql-database)
145 ((connection :accessor database-connection :initarg :connection
146 :type postgresql-connection)))
148 (defmethod database-type ((database postgresql-socket-database))
151 (defmethod database-name-from-spec (connection-spec
152 (database-type (eql :postgresql-socket)))
153 (check-connection-spec connection-spec database-type
154 (host db user password &optional port options tty))
155 (destructuring-bind (host db user password &optional port options tty)
157 (declare (ignore password options tty))
162 (pathname (namestring host))
168 (integer (write-to-string port))
172 (defmethod database-connect (connection-spec
173 (database-type (eql :postgresql-socket)))
174 (check-connection-spec connection-spec database-type
175 (host db user password &optional port options tty))
176 (destructuring-bind (host db user password &optional
177 (port +postgresql-server-default-port+)
178 (options "") (tty ""))
181 (handler-bind ((postgresql-warning
186 (list (princ-to-string c))))))
187 (open-postgresql-connection :host host :port port
188 :options options :tty tty
189 :database db :user user
191 (postgresql-error (c)
193 (error 'sql-connection-error
194 :database-type database-type
195 :connection-spec connection-spec
196 :error-id (type-of c)
197 :message (postgresql-condition-message c)))
198 (:no-error (connection)
199 ;; Success, make instance
200 (make-instance 'postgresql-socket-database
201 :name (database-name-from-spec connection-spec
203 :database-type :postgresql-socket
204 :connection-spec connection-spec
205 :connection connection)))))
207 (defmethod database-disconnect ((database postgresql-socket-database))
208 (close-postgresql-connection (database-connection database))
211 (defmethod database-query (expression (database postgresql-socket-database) result-types field-names)
212 (let ((connection (database-connection database)))
213 (with-postgresql-handlers (database expression)
214 (start-query-execution connection expression)
215 (multiple-value-bind (status cursor)
216 (wait-for-query-results connection)
217 (unless (eq status :cursor)
218 (close-postgresql-connection connection)
219 (error 'sql-database-data-error
221 :expression expression
222 :error-id "missing-result"
223 :message "Didn't receive result cursor for query."))
224 (setq result-types (canonicalize-types result-types cursor))
226 (loop for row = (read-cursor-row cursor result-types)
230 (unless (null (wait-for-query-results connection))
231 (close-postgresql-connection connection)
232 (error 'sql-database-data-error
234 :expression expression
235 :error-id "multiple-results"
236 :message "Received multiple results for query.")))
238 (mapcar #'car (postgresql-cursor-fields cursor))))))))
240 (defmethod database-execute-command
241 (expression (database postgresql-socket-database))
242 (let ((connection (database-connection database)))
243 (with-postgresql-handlers (database expression)
244 (start-query-execution connection expression)
245 (multiple-value-bind (status result)
246 (wait-for-query-results connection)
247 (when (eq status :cursor)
249 (multiple-value-bind (row stuff)
250 (skip-cursor-row result)
252 (setq status :completed result stuff)
257 ((eq status :completed)
258 (unless (null (wait-for-query-results connection))
259 (close-postgresql-connection connection)
260 (error 'sql-database-data-error
262 :expression expression
263 :error-id "multiple-results"
264 :message "Received multiple results for command."))
267 (close-postgresql-connection connection)
268 (error 'sql-database-data-error
270 :expression expression
271 :errno "missing-result"
272 :message "Didn't receive completion for command.")))))))
274 (defstruct postgresql-socket-result-set
279 (defmethod database-query-result-set ((expression string)
280 (database postgresql-socket-database)
281 &key full-set result-types)
282 (declare (ignore full-set))
283 (let ((connection (database-connection database)))
284 (with-postgresql-handlers (database expression)
285 (start-query-execution connection expression)
286 (multiple-value-bind (status cursor)
287 (wait-for-query-results connection)
288 (unless (eq status :cursor)
289 (close-postgresql-connection connection)
290 (error 'sql-database-data-error
292 :expression expression
293 :error-id "missing-result"
294 :message "Didn't receive result cursor for query."))
295 (values (make-postgresql-socket-result-set
298 :types (canonicalize-types result-types cursor))
299 (length (postgresql-cursor-fields cursor)))))))
301 (defmethod database-dump-result-set (result-set
302 (database postgresql-socket-database))
303 (if (postgresql-socket-result-set-done result-set)
305 (with-postgresql-handlers (database)
306 (loop while (skip-cursor-row
307 (postgresql-socket-result-set-cursor result-set))
308 finally (setf (postgresql-socket-result-set-done result-set) t)))))
310 (defmethod database-store-next-row (result-set
311 (database postgresql-socket-database)
313 (let ((cursor (postgresql-socket-result-set-cursor result-set)))
314 (with-postgresql-handlers (database)
315 (if (copy-cursor-row cursor
317 (postgresql-socket-result-set-types
321 (setf (postgresql-socket-result-set-done result-set) t)
322 (wait-for-query-results (database-connection database)))))))
324 (defmethod database-create (connection-spec (type (eql :postgresql-socket)))
325 (destructuring-bind (host name user password &optional port options tty) connection-spec
326 (let ((database (database-connect (list host "postgres" user password)
328 (setf (slot-value database 'clsql-sys::state) :open)
330 (database-execute-command (format nil "create database ~A" name) database)
331 (database-disconnect database)))))
333 (defmethod database-destroy (connection-spec (type (eql :postgresql-socket)))
334 (destructuring-bind (host name user password &optional port optional tty) connection-spec
335 (let ((database (database-connect (list host "postgres" user password)
337 (setf (slot-value database 'clsql-sys::state) :open)
339 (database-execute-command (format nil "drop database ~A" name) database)
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))