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. Essentially if we get a
74 generic term for a type that our auto typer pulls a better type for,
76 (let ((length-types (length types)))
77 (loop for i from 0 below (length auto-list)
78 for auto = (nth i auto-list)
80 (if (or (>= i length-types)
81 (member (nth i types) (list T :int :double)))
86 (defun convert-to-clsql-warning (database condition)
87 (ecase *backend-warning-behavior*
89 (warn 'sql-database-warning :database database
90 :message (postgresql-condition-message condition)))
92 (error 'sql-database-error :database database
93 :message (format nil "Warning upgraded to error: ~A"
94 (postgresql-condition-message condition))))
99 (defun convert-to-clsql-error (database expression condition)
100 (error 'sql-database-data-error
102 :expression expression
103 :error-id (type-of condition)
104 :message (postgresql-condition-message condition)))
106 (defmacro with-postgresql-handlers
107 ((database &optional expression)
109 (let ((database-var (gensym))
110 (expression-var (gensym)))
111 `(let ((,database-var ,database)
112 (,expression-var ,expression))
113 (handler-bind ((postgresql-warning
115 (convert-to-clsql-warning ,database-var c)))
118 (convert-to-clsql-error
119 ,database-var ,expression-var c))))
122 (defmethod database-initialize-database-type ((database-type
123 (eql :postgresql-socket)))
126 (defclass postgresql-socket-database (generic-postgresql-database)
127 ((connection :accessor database-connection :initarg :connection
128 :type postgresql-connection)))
130 (defmethod database-type ((database postgresql-socket-database))
133 (defmethod database-name-from-spec (connection-spec
134 (database-type (eql :postgresql-socket)))
135 (check-connection-spec connection-spec database-type
136 (host db user password &optional port options tty))
137 (destructuring-bind (host db user password &optional port options tty)
139 (declare (ignore password options tty))
144 (pathname (namestring host))
150 (integer (write-to-string port))
154 (defmethod database-connect (connection-spec
155 (database-type (eql :postgresql-socket)))
156 (check-connection-spec connection-spec database-type
157 (host db user password &optional port options tty))
158 (destructuring-bind (host db user password &optional
159 (port +postgresql-server-default-port+)
160 (options "") (tty ""))
163 (handler-bind ((postgresql-warning
168 (list (princ-to-string c))))))
169 (open-postgresql-connection :host host :port port
170 :options options :tty tty
171 :database db :user user
173 (postgresql-error (c)
175 (error 'sql-connection-error
176 :database-type database-type
177 :connection-spec connection-spec
178 :error-id (type-of c)
179 :message (postgresql-condition-message c)))
180 (:no-error (connection)
181 ;; Success, make instance
182 (make-instance 'postgresql-socket-database
183 :name (database-name-from-spec connection-spec
185 :database-type :postgresql-socket
186 :connection-spec connection-spec
187 :connection connection)))))
189 (defmethod database-disconnect ((database postgresql-socket-database))
190 (close-postgresql-connection (database-connection database))
193 (defmethod database-query (expression (database postgresql-socket-database) result-types field-names)
194 (let ((connection (database-connection database)))
195 (with-postgresql-handlers (database expression)
196 (start-query-execution connection expression)
197 (multiple-value-bind (status cursor)
198 (wait-for-query-results connection)
199 (unless (eq status :cursor)
200 (close-postgresql-connection connection)
201 (error 'sql-database-data-error
203 :expression expression
204 :error-id "missing-result"
205 :message "Didn't receive result cursor for query."))
206 (setq result-types (canonicalize-types result-types cursor))
208 (loop for row = (read-cursor-row cursor result-types)
212 (unless (null (wait-for-query-results connection))
213 (close-postgresql-connection connection)
214 (error 'sql-database-data-error
216 :expression expression
217 :error-id "multiple-results"
218 :message "Received multiple results for query.")))
220 (mapcar #'car (postgresql-cursor-fields cursor))))))))
222 (defmethod database-execute-command
223 (expression (database postgresql-socket-database))
224 (let ((connection (database-connection database)))
225 (with-postgresql-handlers (database expression)
226 (start-query-execution connection expression)
227 (multiple-value-bind (status result)
228 (wait-for-query-results connection)
229 (when (eq status :cursor)
231 (multiple-value-bind (row stuff)
232 (skip-cursor-row result)
234 (setq status :completed result stuff)
239 ((eq status :completed)
240 (unless (null (wait-for-query-results connection))
241 (close-postgresql-connection connection)
242 (error 'sql-database-data-error
244 :expression expression
245 :error-id "multiple-results"
246 :message "Received multiple results for command."))
249 (close-postgresql-connection connection)
250 (error 'sql-database-data-error
252 :expression expression
253 :errno "missing-result"
254 :message "Didn't receive completion for command.")))))))
256 (defstruct postgresql-socket-result-set
261 (defmethod database-query-result-set ((expression string)
262 (database postgresql-socket-database)
263 &key full-set result-types)
264 (declare (ignore full-set))
265 (let ((connection (database-connection database)))
266 (with-postgresql-handlers (database expression)
267 (start-query-execution connection expression)
268 (multiple-value-bind (status cursor)
269 (wait-for-query-results connection)
270 (unless (eq status :cursor)
271 (close-postgresql-connection connection)
272 (error 'sql-database-data-error
274 :expression expression
275 :error-id "missing-result"
276 :message "Didn't receive result cursor for query."))
277 (values (make-postgresql-socket-result-set
280 :types (canonicalize-types result-types cursor))
281 (length (postgresql-cursor-fields cursor)))))))
283 (defmethod database-dump-result-set (result-set
284 (database postgresql-socket-database))
285 (if (postgresql-socket-result-set-done result-set)
287 (with-postgresql-handlers (database)
288 (loop while (skip-cursor-row
289 (postgresql-socket-result-set-cursor result-set))
290 finally (setf (postgresql-socket-result-set-done result-set) t)))))
292 (defmethod database-store-next-row (result-set
293 (database postgresql-socket-database)
295 (let ((cursor (postgresql-socket-result-set-cursor result-set)))
296 (with-postgresql-handlers (database)
297 (if (copy-cursor-row cursor
299 (postgresql-socket-result-set-types
303 (setf (postgresql-socket-result-set-done result-set) t)
304 (wait-for-query-results (database-connection database)))))))
306 (defmethod database-create (connection-spec (type (eql :postgresql-socket)))
307 (destructuring-bind (host name user password &optional port options tty) connection-spec
308 (let ((database (database-connect (list host "postgres" user password)
310 (setf (slot-value database 'clsql-sys::state) :open)
312 (database-execute-command (format nil "create database ~A" name) database)
313 (database-disconnect database)))))
315 (defmethod database-destroy (connection-spec (type (eql :postgresql-socket)))
316 (destructuring-bind (host name user password &optional port optional tty) connection-spec
317 (let ((database (database-connect (list host "postgres" user password)
319 (setf (slot-value database 'clsql-sys::state) :open)
321 (database-execute-command (format nil "drop database ~A" name) database)
322 (database-disconnect database)))))
325 (defmethod database-probe (connection-spec (type (eql :postgresql-socket)))
326 (when (find (second connection-spec) (database-list connection-spec type)
327 :test #'string-equal)
331 ;; Database capabilities
333 (defmethod db-backend-has-create/destroy-db? ((db-type (eql :postgresql-socket)))
336 (defmethod db-type-has-fancy-math? ((db-type (eql :postgresql-socket)))
339 (defmethod db-type-default-case ((db-type (eql :postgresql-socket)))
342 (defmethod database-underlying-type ((database postgresql-socket-database))
345 (when (clsql-sys:database-type-library-loaded :postgresql-socket)
346 (clsql-sys:initialize-database-type :database-type :postgresql-socket))