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 ;;;; Programmers: Kevin M. Rosenberg based on
8 ;;;; Original code by Pierre R. Mai
9 ;;;; Date Started: Feb 2002
13 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
14 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
16 ;;;; CLSQL users are granted the rights to distribute and use this software
17 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
18 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
19 ;;;; *************************************************************************
21 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
24 (defpackage :clsql-postgresql-socket
25 (:use :common-lisp :clsql-base-sys :postgresql-socket)
26 (:export #:postgresql-socket-database)
27 (:documentation "This is the CLSQL socket interface to PostgreSQL."))
29 (in-package :clsql-postgresql-socket)
31 ;; interface foreign library loading routines
34 (clsql-base-sys:database-type-load-foreign :postgresql-socket)
37 ;; Field type conversion
39 (defun make-type-list-for-auto (cursor)
40 (let* ((fields (postgresql-cursor-fields cursor))
41 (num-fields (length fields))
43 (dotimes (i num-fields)
45 (push (canonical-field-type fields i) new-types))
46 (nreverse new-types)))
48 (defun canonical-field-type (fields index)
49 "Extracts canonical field type from fields list"
50 (let ((oid (cadr (nth index fields))))
58 ((#.pgsql-ftype#float4
64 (defun canonicalize-types (types cursor)
67 (let ((auto-list (make-type-list-for-auto cursor)))
70 (canonicalize-type-list types auto-list))
76 (defun canonicalize-type-list (types auto-list)
77 "Ensure a field type list meets expectations.
78 Duplicated from clsql-uffi package so that this interface
79 doesn't depend on UFFI."
80 (let ((length-types (length types))
82 (loop for i from 0 below (length auto-list)
84 (if (>= i length-types)
85 (push t new-types) ;; types is shorted than num-fields
89 (case (nth i auto-list)
97 (case (nth i auto-list)
105 (nreverse new-types)))
108 (defun convert-to-clsql-warning (database condition)
109 (warn 'clsql-database-warning :database database
110 :message (postgresql-condition-message condition)))
112 (defun convert-to-clsql-error (database expression condition)
113 (error 'clsql-sql-error :database database
114 :expression expression
115 :errno (type-of condition)
116 :error (postgresql-condition-message condition)))
118 (defmacro with-postgresql-handlers
119 ((database &optional expression)
121 (let ((database-var (gensym))
122 (expression-var (gensym)))
123 `(let ((,database-var ,database)
124 (,expression-var ,expression))
125 (handler-bind ((postgresql-warning
127 (convert-to-clsql-warning ,database-var c)))
130 (convert-to-clsql-error
131 ,database-var ,expression-var c))))
132 ;; KMR - removed double @@
135 (defmethod database-initialize-database-type ((database-type
136 (eql :postgresql-socket)))
139 (defclass postgresql-socket-database (database)
140 ((connection :accessor database-connection :initarg :connection
141 :type postgresql-connection)))
143 (defmethod database-type ((database postgresql-socket-database))
146 (defmethod database-name-from-spec (connection-spec
147 (database-type (eql :postgresql-socket)))
148 (check-connection-spec connection-spec database-type
149 (host db user password &optional port options tty))
150 (destructuring-bind (host db user password &optional port options tty)
152 (declare (ignore password options tty))
155 (pathname (namestring host))
161 (integer (write-to-string port))
165 (defmethod database-connect (connection-spec
166 (database-type (eql :postgresql-socket)))
167 (check-connection-spec connection-spec database-type
168 (host db user password &optional port options tty))
169 (destructuring-bind (host db user password &optional
170 (port +postgresql-server-default-port+)
171 (options "") (tty ""))
174 (handler-bind ((postgresql-warning
176 (warn 'clsql-simple-warning
179 (list (princ-to-string c))))))
180 (open-postgresql-connection :host host :port port
181 :options options :tty tty
182 :database db :user user
184 (postgresql-error (c)
186 (error 'clsql-connect-error
187 :database-type database-type
188 :connection-spec connection-spec
190 :error (postgresql-condition-message c)))
191 (:no-error (connection)
192 ;; Success, make instance
193 (make-instance 'postgresql-socket-database
194 :name (database-name-from-spec connection-spec
196 :connection-spec connection-spec
197 :connection connection)))))
199 (defmethod database-disconnect ((database postgresql-socket-database))
200 (close-postgresql-connection (database-connection database))
203 (defmethod database-query (expression (database postgresql-socket-database) types)
204 (let ((connection (database-connection database)))
205 (with-postgresql-handlers (database expression)
206 (start-query-execution connection expression)
207 (multiple-value-bind (status cursor)
208 (wait-for-query-results connection)
209 (unless (eq status :cursor)
210 (close-postgresql-connection connection)
211 (error 'clsql-sql-error
213 :expression expression
214 :errno 'missing-result
215 :error "Didn't receive result cursor for query."))
216 (setq types (canonicalize-types types cursor))
217 (loop for row = (read-cursor-row cursor types)
221 (unless (null (wait-for-query-results connection))
222 (close-postgresql-connection connection)
223 (error 'clsql-sql-error
225 :expression expression
226 :errno 'multiple-results
227 :error "Received multiple results for query.")))))))
229 (defmethod database-execute-command
230 (expression (database postgresql-socket-database))
231 (let ((connection (database-connection database)))
232 (with-postgresql-handlers (database expression)
233 (start-query-execution connection expression)
234 (multiple-value-bind (status result)
235 (wait-for-query-results connection)
236 (when (eq status :cursor)
238 (multiple-value-bind (row stuff)
239 (skip-cursor-row result)
241 (setq status :completed result stuff)
246 ((eq status :completed)
247 (unless (null (wait-for-query-results connection))
248 (close-postgresql-connection connection)
249 (error 'clsql-sql-error
251 :expression expression
252 :errno 'multiple-results
253 :error "Received multiple results for command."))
256 (close-postgresql-connection connection)
257 (error 'clsql-sql-error
259 :expression expression
260 :errno 'missing-result
261 :error "Didn't receive completion for command.")))))))
263 (defstruct postgresql-socket-result-set
268 (defmethod database-query-result-set (expression (database postgresql-socket-database)
271 (declare (ignore full-set))
272 (let ((connection (database-connection database)))
273 (with-postgresql-handlers (database expression)
274 (start-query-execution connection expression)
275 (multiple-value-bind (status cursor)
276 (wait-for-query-results connection)
277 (unless (eq status :cursor)
278 (close-postgresql-connection connection)
279 (error 'clsql-sql-error
281 :expression expression
282 :errno 'missing-result
283 :error "Didn't receive result cursor for query."))
284 (values (make-postgresql-socket-result-set
287 :types (canonicalize-types types cursor))
288 (length (postgresql-cursor-fields cursor)))))))
290 (defmethod database-dump-result-set (result-set
291 (database postgresql-socket-database))
292 (if (postgresql-socket-result-set-done result-set)
294 (with-postgresql-handlers (database)
295 (loop while (skip-cursor-row
296 (postgresql-socket-result-set-cursor result-set))
297 finally (setf (postgresql-socket-result-set-done result-set) t)))))
299 (defmethod database-store-next-row (result-set
300 (database postgresql-socket-database)
302 (let ((cursor (postgresql-socket-result-set-cursor result-set)))
303 (with-postgresql-handlers (database)
304 (if (copy-cursor-row cursor
306 (postgresql-socket-result-set-types
310 (setf (postgresql-socket-result-set-done result-set) t)
311 (wait-for-query-results (database-connection database)))))))
313 (when (clsql-base-sys:database-type-library-loaded :postgresql-socket)
314 (clsql-base-sys:initialize-database-type :database-type :postgresql-socket))