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.4 2002/03/24 22:25:51 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)))
25 (defpackage :clsql-postgresql-socket
26 (:use :common-lisp :clsql-sys :postgresql-socket)
27 (:export #:postgresql-socket-database)
28 (:documentation "This is the CLSQL socket interface to PostgreSQL."))
30 (in-package :clsql-postgresql-socket)
32 (defun convert-to-clsql-warning (database condition)
33 (warn 'clsql-database-warning :database database
34 :message (postgresql-condition-message condition)))
36 (defun convert-to-clsql-error (database expression condition)
37 (error 'clsql-sql-error :database database
38 :expression expression
39 :errno (type-of condition)
40 :error (postgresql-condition-message condition)))
42 (defmacro with-postgresql-handlers
43 ((database &optional expression)
45 (let ((database-var (gensym))
46 (expression-var (gensym)))
47 `(let ((,database-var ,database)
48 (,expression-var ,expression))
49 (handler-bind ((postgresql-warning
51 (convert-to-clsql-warning ,database-var c)))
54 (convert-to-clsql-error
55 ,database-var ,expression-var c))))
56 ;; KMR - removed double @@
59 (defmethod database-initialize-database-type
60 ((database-type (eql :postgresql-socket)))
63 (defclass postgresql-socket-database (database)
64 ((connection :accessor database-connection :initarg :connection
65 :type postgresql-connection)))
67 (defmethod database-name-from-spec
68 (connection-spec (database-type (eql :postgresql-socket)))
69 (check-connection-spec connection-spec database-type
70 (host db user password &optional port options tty))
71 (destructuring-bind (host db user password &optional port options tty)
73 (declare (ignore password options tty))
74 (concatenate 'string host (if port ":") (if port port) "/" db "/" user)))
76 (defmethod database-connect
77 (connection-spec (database-type (eql :postgresql-socket)))
78 (check-connection-spec connection-spec database-type
79 (host db user password &optional port options tty))
80 (destructuring-bind (host db user password &optional
81 (port +postgresql-server-default-port+)
82 (options "") (tty ""))
85 (handler-bind ((postgresql-warning
87 (warn 'clsql-simple-warning
90 (list (princ-to-string c))))))
91 (open-postgresql-connection :host host :port port
92 :options options :tty tty
93 :database db :user user
95 (:no-error (connection)
96 ;; Success, make instance
97 (make-instance 'postgresql-socket-database
98 :name (database-name-from-spec connection-spec
100 :connection connection))
101 (postgresql-error (c)
103 (error 'clsql-connect-error
104 :database-type database-type
105 :connection-spec connection-spec
107 :error (postgresql-condition-message c))))))
109 (defmethod database-disconnect ((database postgresql-socket-database))
110 (close-postgresql-connection (database-connection database))
113 (defmethod database-query (expression (database postgresql-socket-database) field-types)
114 (let ((connection (database-connection database)))
115 (with-postgresql-handlers (database expression)
116 (start-query-execution connection expression)
117 (multiple-value-bind (status cursor)
118 (wait-for-query-results connection)
119 (unless (eq status :cursor)
120 (close-postgresql-connection connection)
121 (error 'clsql-sql-error
123 :expression expression
124 :errno 'missing-result
125 :error "Didn't receive result cursor for query."))
126 (loop for row = (read-cursor-row cursor)
130 (unless (null (wait-for-query-results connection))
131 (close-postgresql-connection connection)
132 (error 'clsql-sql-error
134 :expression expression
135 :errno 'multiple-results
136 :error "Received multiple results for query.")))))))
138 (defmethod database-execute-command
139 (expression (database postgresql-socket-database))
140 (let ((connection (database-connection database)))
141 (with-postgresql-handlers (database expression)
142 (start-query-execution connection expression)
143 (multiple-value-bind (status result)
144 (wait-for-query-results connection)
145 (when (eq status :cursor)
147 (multiple-value-bind (row stuff)
148 (skip-cursor-row result)
150 (setq status :completed result stuff)
155 ((eq status :completed)
156 (unless (null (wait-for-query-results connection))
157 (close-postgresql-connection connection)
158 (error 'clsql-sql-error
160 :expression expression
161 :errno 'multiple-results
162 :error "Received multiple results for command."))
165 (close-postgresql-connection connection)
166 (error 'clsql-sql-error
168 :expression expression
169 :errno 'missing-result
170 :error "Didn't receive completion for command.")))))))
172 (defstruct postgresql-socket-result-set
177 (defmethod database-query-result-set (expression (database postgresql-socket-database)
178 &key full-set field-types
180 (declare (ignore full-set))
181 (let ((connection (database-connection database)))
182 (with-postgresql-handlers (database expression)
183 (start-query-execution connection expression)
184 (multiple-value-bind (status cursor)
185 (wait-for-query-results connection)
186 (unless (eq status :cursor)
187 (close-postgresql-connection connection)
188 (error 'clsql-sql-error
190 :expression expression
191 :errno 'missing-result
192 :error "Didn't receive result cursor for query."))
193 (values (make-postgresql-socket-result-set
196 :field-types field-types)
197 (length (postgresql-cursor-fields cursor)))))))
199 (defmethod database-dump-result-set (result-set
200 (database postgresql-socket-database))
201 (if (postgresql-socket-result-set-done result-set)
203 (with-postgresql-handlers (database)
204 (loop while (skip-cursor-row
205 (postgresql-socket-result-set-cursor result-set))
206 finally (setf (postgresql-socket-result-set-done result-set) t)))))
208 (defmethod database-store-next-row (result-set
209 (database postgresql-socket-database)
211 (let ((cursor (postgresql-socket-result-set-cursor result-set)))
212 (with-postgresql-handlers (database)
213 (if (copy-cursor-row cursor list)
216 (setf (postgresql-socket-result-set-done result-set) t)
217 (wait-for-query-results (database-connection database)))))))