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
11 ;;;; $Id: postgresql-socket-sql.cl,v 1.11 2002/04/27 20:58:11 kevin Exp $
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-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
33 (defmethod database-type-library-loaded ((database-type (eql :postgresql-socket)))
36 (defmethod clsql-sys:database-type-load-foreign ((database-type (eql :postgresql-socket)))
39 (clsql-sys:database-type-load-foreign :postgresql-socket)
42 ;; Field type conversion
44 (defun make-type-list-for-auto (cursor)
45 (let* ((fields (postgresql-cursor-fields cursor))
46 (num-fields (length fields))
48 (dotimes (i num-fields)
50 (push (canonical-field-type fields i) new-types))
51 (nreverse new-types)))
53 (defun canonical-field-type (fields index)
54 "Extracts canonical field type from fields list"
55 (let ((oid (cadr (nth index fields))))
63 ((#.pgsql-ftype#float4
69 (defun canonicalize-types (types cursor)
72 (let ((auto-list (make-type-list-for-auto cursor)))
75 (canonicalize-type-list types auto-list))
81 (defun canonicalize-type-list (types auto-list)
82 "Ensure a field type list meets expectations.
83 Duplicated from clsql-uffi package so that this interface
84 doesn't depend on UFFI."
85 (let ((length-types (length types))
87 (loop for i from 0 below (length auto-list)
89 (if (>= i length-types)
90 (push t new-types) ;; types is shorted than num-fields
94 (case (nth i auto-list)
102 (case (nth i auto-list)
110 (nreverse new-types)))
113 (defun convert-to-clsql-warning (database condition)
114 (warn 'clsql-database-warning :database database
115 :message (postgresql-condition-message condition)))
117 (defun convert-to-clsql-error (database expression condition)
118 (error 'clsql-sql-error :database database
119 :expression expression
120 :errno (type-of condition)
121 :error (postgresql-condition-message condition)))
123 (defmacro with-postgresql-handlers
124 ((database &optional expression)
126 (let ((database-var (gensym))
127 (expression-var (gensym)))
128 `(let ((,database-var ,database)
129 (,expression-var ,expression))
130 (handler-bind ((postgresql-warning
132 (convert-to-clsql-warning ,database-var c)))
135 (convert-to-clsql-error
136 ,database-var ,expression-var c))))
137 ;; KMR - removed double @@
140 (defmethod database-initialize-database-type ((database-type
141 (eql :postgresql-socket)))
144 (defclass postgresql-socket-database (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))
158 (concatenate 'string host (if port ":") (if port port) "/" db "/" user)))
160 (defmethod database-connect (connection-spec
161 (database-type (eql :postgresql-socket)))
162 (check-connection-spec connection-spec database-type
163 (host db user password &optional port options tty))
164 (destructuring-bind (host db user password &optional
165 (port +postgresql-server-default-port+)
166 (options "") (tty ""))
169 (handler-bind ((postgresql-warning
171 (warn 'clsql-simple-warning
174 (list (princ-to-string c))))))
175 (open-postgresql-connection :host host :port port
176 :options options :tty tty
177 :database db :user user
179 (:no-error (connection)
180 ;; Success, make instance
181 (make-instance 'postgresql-socket-database
182 :name (database-name-from-spec connection-spec
184 :connection-spec connection-spec
185 :connection connection))
186 (postgresql-error (c)
188 (error 'clsql-connect-error
189 :database-type database-type
190 :connection-spec connection-spec
192 :error (postgresql-condition-message c))))))
194 (defmethod database-disconnect ((database postgresql-socket-database))
195 (close-postgresql-connection (database-connection database))
198 (defmethod database-query (expression (database postgresql-socket-database) types)
199 (let ((connection (database-connection database)))
200 (with-postgresql-handlers (database expression)
201 (start-query-execution connection expression)
202 (multiple-value-bind (status cursor)
203 (wait-for-query-results connection)
204 (unless (eq status :cursor)
205 (close-postgresql-connection connection)
206 (error 'clsql-sql-error
208 :expression expression
209 :errno 'missing-result
210 :error "Didn't receive result cursor for query."))
211 (setq types (canonicalize-types types cursor))
212 (loop for row = (read-cursor-row cursor types)
216 (unless (null (wait-for-query-results connection))
217 (close-postgresql-connection connection)
218 (error 'clsql-sql-error
220 :expression expression
221 :errno 'multiple-results
222 :error "Received multiple results for query.")))))))
224 (defmethod database-execute-command
225 (expression (database postgresql-socket-database))
226 (let ((connection (database-connection database)))
227 (with-postgresql-handlers (database expression)
228 (start-query-execution connection expression)
229 (multiple-value-bind (status result)
230 (wait-for-query-results connection)
231 (when (eq status :cursor)
233 (multiple-value-bind (row stuff)
234 (skip-cursor-row result)
236 (setq status :completed result stuff)
241 ((eq status :completed)
242 (unless (null (wait-for-query-results connection))
243 (close-postgresql-connection connection)
244 (error 'clsql-sql-error
246 :expression expression
247 :errno 'multiple-results
248 :error "Received multiple results for command."))
251 (close-postgresql-connection connection)
252 (error 'clsql-sql-error
254 :expression expression
255 :errno 'missing-result
256 :error "Didn't receive completion for command.")))))))
258 (defstruct postgresql-socket-result-set
263 (defmethod database-query-result-set (expression (database postgresql-socket-database)
266 (declare (ignore full-set))
267 (let ((connection (database-connection database)))
268 (with-postgresql-handlers (database expression)
269 (start-query-execution connection expression)
270 (multiple-value-bind (status cursor)
271 (wait-for-query-results connection)
272 (unless (eq status :cursor)
273 (close-postgresql-connection connection)
274 (error 'clsql-sql-error
276 :expression expression
277 :errno 'missing-result
278 :error "Didn't receive result cursor for query."))
279 (values (make-postgresql-socket-result-set
282 :types (canonicalize-types types cursor))
283 (length (postgresql-cursor-fields cursor)))))))
285 (defmethod database-dump-result-set (result-set
286 (database postgresql-socket-database))
287 (if (postgresql-socket-result-set-done result-set)
289 (with-postgresql-handlers (database)
290 (loop while (skip-cursor-row
291 (postgresql-socket-result-set-cursor result-set))
292 finally (setf (postgresql-socket-result-set-done result-set) t)))))
294 (defmethod database-store-next-row (result-set
295 (database postgresql-socket-database)
297 (let ((cursor (postgresql-socket-result-set-cursor result-set)))
298 (with-postgresql-handlers (database)
299 (if (copy-cursor-row cursor
301 (postgresql-socket-result-set-types
305 (setf (postgresql-socket-result-set-done result-set) t)
306 (wait-for-query-results (database-connection database)))))))