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 (in-package #:cl-user)
23 (defpackage :clsql-postgresql-socket
24 (:use #:common-lisp #:clsql-base-sys #:postgresql-socket)
25 (:export #:postgresql-socket-database)
26 (:documentation "This is the CLSQL socket interface to PostgreSQL."))
28 (in-package #:clsql-postgresql-socket)
30 ;; interface foreign library loading routines
33 (clsql-base-sys:database-type-load-foreign :postgresql-socket)
36 ;; Field type conversion
38 (defun make-type-list-for-auto (cursor)
39 (let* ((fields (postgresql-cursor-fields cursor))
40 (num-fields (length fields))
42 (dotimes (i num-fields)
44 (push (canonical-field-type fields i) new-types))
45 (nreverse new-types)))
47 (defun canonical-field-type (fields index)
48 "Extracts canonical field type from fields list"
49 (let ((oid (cadr (nth index fields))))
57 ((#.pgsql-ftype#float4
63 (defun canonicalize-types (types cursor)
66 (let ((auto-list (make-type-list-for-auto cursor)))
69 (canonicalize-type-list types auto-list))
75 (defun canonicalize-type-list (types auto-list)
76 "Ensure a field type list meets expectations.
77 Duplicated from clsql-uffi package so that this interface
78 doesn't depend on UFFI."
79 (let ((length-types (length types))
81 (loop for i from 0 below (length auto-list)
83 (if (>= i length-types)
84 (push t new-types) ;; types is shorted than num-fields
88 (case (nth i auto-list)
96 (case (nth i auto-list)
104 (nreverse new-types)))
107 (defun convert-to-clsql-warning (database condition)
108 (warn 'clsql-database-warning :database database
109 :message (postgresql-condition-message condition)))
111 (defun convert-to-clsql-error (database expression condition)
112 (error 'clsql-sql-error :database database
113 :expression expression
114 :errno (type-of condition)
115 :error (postgresql-condition-message condition)))
117 (defmacro with-postgresql-handlers
118 ((database &optional expression)
120 (let ((database-var (gensym))
121 (expression-var (gensym)))
122 `(let ((,database-var ,database)
123 (,expression-var ,expression))
124 (handler-bind ((postgresql-warning
126 (convert-to-clsql-warning ,database-var c)))
129 (convert-to-clsql-error
130 ,database-var ,expression-var c))))
131 ;; KMR - removed double @@
134 (defmethod database-initialize-database-type ((database-type
135 (eql :postgresql-socket)))
138 (defclass postgresql-socket-database (database)
139 ((connection :accessor database-connection :initarg :connection
140 :type postgresql-connection)))
142 (defmethod database-type ((database postgresql-socket-database))
145 (defmethod database-name-from-spec (connection-spec
146 (database-type (eql :postgresql-socket)))
147 (check-connection-spec connection-spec database-type
148 (host db user password &optional port options tty))
149 (destructuring-bind (host db user password &optional port options tty)
151 (declare (ignore password options tty))
156 (pathname (namestring host))
162 (integer (write-to-string port))
166 (defmethod database-connect (connection-spec
167 (database-type (eql :postgresql-socket)))
168 (check-connection-spec connection-spec database-type
169 (host db user password &optional port options tty))
170 (destructuring-bind (host db user password &optional
171 (port +postgresql-server-default-port+)
172 (options "") (tty ""))
175 (handler-bind ((postgresql-warning
177 (warn 'clsql-simple-warning
180 (list (princ-to-string c))))))
181 (open-postgresql-connection :host host :port port
182 :options options :tty tty
183 :database db :user user
185 (postgresql-error (c)
187 (error 'clsql-connect-error
188 :database-type database-type
189 :connection-spec connection-spec
191 :error (postgresql-condition-message c)))
192 (:no-error (connection)
193 ;; Success, make instance
194 (make-instance 'postgresql-socket-database
195 :name (database-name-from-spec connection-spec
197 :database-type :postgresql-socket
198 :connection-spec connection-spec
199 :connection connection)))))
201 (defmethod database-disconnect ((database postgresql-socket-database))
202 (close-postgresql-connection (database-connection database))
205 (defmethod database-query (expression (database postgresql-socket-database) result-types)
206 (let ((connection (database-connection database)))
207 (with-postgresql-handlers (database expression)
208 (start-query-execution connection expression)
209 (multiple-value-bind (status cursor)
210 (wait-for-query-results connection)
211 (unless (eq status :cursor)
212 (close-postgresql-connection connection)
213 (error 'clsql-sql-error
215 :expression expression
216 :errno 'missing-result
217 :error "Didn't receive result cursor for query."))
218 (setq result-types (canonicalize-types result-types cursor))
219 (loop for row = (read-cursor-row cursor result-types)
223 (unless (null (wait-for-query-results connection))
224 (close-postgresql-connection connection)
225 (error 'clsql-sql-error
227 :expression expression
228 :errno 'multiple-results
229 :error "Received multiple results for query.")))))))
231 (defmethod database-execute-command
232 (expression (database postgresql-socket-database))
233 (let ((connection (database-connection database)))
234 (with-postgresql-handlers (database expression)
235 (start-query-execution connection expression)
236 (multiple-value-bind (status result)
237 (wait-for-query-results connection)
238 (when (eq status :cursor)
240 (multiple-value-bind (row stuff)
241 (skip-cursor-row result)
243 (setq status :completed result stuff)
248 ((eq status :completed)
249 (unless (null (wait-for-query-results connection))
250 (close-postgresql-connection connection)
251 (error 'clsql-sql-error
253 :expression expression
254 :errno 'multiple-results
255 :error "Received multiple results for command."))
258 (close-postgresql-connection connection)
259 (error 'clsql-sql-error
261 :expression expression
262 :errno 'missing-result
263 :error "Didn't receive completion for command.")))))))
265 (defstruct postgresql-socket-result-set
270 (defmethod database-query-result-set ((expression string)
271 (database postgresql-socket-database)
272 &key full-set result-types)
273 (declare (ignore full-set))
274 (let ((connection (database-connection database)))
275 (with-postgresql-handlers (database expression)
276 (start-query-execution connection expression)
277 (multiple-value-bind (status cursor)
278 (wait-for-query-results connection)
279 (unless (eq status :cursor)
280 (close-postgresql-connection connection)
281 (error 'clsql-sql-error
283 :expression expression
284 :errno 'missing-result
285 :error "Didn't receive result cursor for query."))
286 (values (make-postgresql-socket-result-set
289 :types (canonicalize-types result-types cursor))
290 (length (postgresql-cursor-fields cursor)))))))
292 (defmethod database-dump-result-set (result-set
293 (database postgresql-socket-database))
294 (if (postgresql-socket-result-set-done result-set)
296 (with-postgresql-handlers (database)
297 (loop while (skip-cursor-row
298 (postgresql-socket-result-set-cursor result-set))
299 finally (setf (postgresql-socket-result-set-done result-set) t)))))
301 (defmethod database-store-next-row (result-set
302 (database postgresql-socket-database)
304 (let ((cursor (postgresql-socket-result-set-cursor result-set)))
305 (with-postgresql-handlers (database)
306 (if (copy-cursor-row cursor
308 (postgresql-socket-result-set-types
312 (setf (postgresql-socket-result-set-done result-set) t)
313 (wait-for-query-results (database-connection database)))))))
317 (defmethod database-list-objects-of-type ((database postgresql-socket-database)
320 (cond ((stringp owner)
321 (format nil " AND (relowner=(SELECT usesysid FROM pg_user WHERE (usename='~A')))" owner))
323 (format nil " AND (NOT (relowner=1))"))
328 "SELECT relname FROM pg_class WHERE (relkind = '~A')~A"
333 (defmethod database-list-tables ((database postgresql-socket-database)
335 (database-list-objects-of-type database "r" owner))
337 (defmethod database-list-views ((database postgresql-socket-database)
339 (database-list-objects-of-type database "v" owner))
341 (defmethod database-list-indexes ((database postgresql-socket-database)
343 (database-list-objects-of-type database "i" owner))
345 (defmethod database-list-attributes ((table string)
346 (database postgresql-socket-database)
349 (cond ((stringp owner)
350 (format nil " AND (relowner=(SELECT usesysid FROM pg_user WHERE usename='~A'))" owner))
351 ((null owner) " AND (not (relowner=1))")
356 (format nil "SELECT attname FROM pg_class,pg_attribute WHERE pg_class.oid=attrelid AND relname='~A'~A"
357 (string-downcase table)
362 (remove-if #'(lambda (it) (member it '("cmin"
368 ;; kmr -- added tableoid
369 "tableoid") :test #'equal))
372 (defmethod database-attribute-type (attribute (table string)
373 (database postgresql-socket-database)
376 (cond ((stringp owner)
377 (format nil " AND (relowner=(SELECT usesysid FROM pg_user WHERE usename='~A'))" owner))
378 ((null owner) " AND (not (relowner=1))")
383 (format nil "SELECT pg_type.typname FROM pg_type,pg_class,pg_attribute WHERE pg_class.oid=pg_attribute.attrelid AND pg_class.relname='~A' AND pg_attribute.attname='~A' AND pg_attribute.atttypid=pg_type.oid~A"
384 (string-downcase table)
385 (string-downcase attribute)
389 (intern (string-upcase (car result)) :keyword))))
391 (defmethod database-create-sequence (sequence-name
392 (database postgresql-socket-database))
393 (database-execute-command
394 (concatenate 'string "CREATE SEQUENCE " (sql-escape sequence-name))
397 (defmethod database-drop-sequence (sequence-name
398 (database postgresql-socket-database))
399 (database-execute-command
400 (concatenate 'string "DROP SEQUENCE " (sql-escape sequence-name)) database))
402 (defmethod database-list-sequences ((database postgresql-socket-database)
404 (database-list-objects-of-type database "S" owner))
406 (defmethod database-set-sequence-position (name (position integer)
407 (database postgresql-socket-database))
412 (format nil "SELECT SETVAL ('~A', ~A)" name position)
415 (defmethod database-sequence-next (sequence-name
416 (database postgresql-socket-database))
421 (concatenate 'string "SELECT NEXTVAL ('" (sql-escape sequence-name) "')")
424 (defmethod database-sequence-last (sequence-name (database postgresql-socket-database))
429 (concatenate 'string "SELECT LAST_VALUE ('" sequence-name "')")
433 (defmethod database-create (connection-spec (type (eql :postgresql-socket)))
434 (destructuring-bind (host name user password) connection-spec
435 (let ((database (database-connect (list host "template1" user password)
438 (execute-command (format nil "create database ~A" name))
439 (database-disconnect database)))))
441 (defmethod database-destroy (connection-spec (type (eql :postgresql-socket)))
442 (destructuring-bind (host name user password) connection-spec
443 (let ((database (database-connect (list host "template1" user password)
446 (execute-command (format nil "drop database ~A" name))
447 (database-disconnect database)))))
449 (defmethod database-probe (connection-spec (type (eql :postgresql-socket)))
450 (destructuring-bind (host name user password) connection-spec
451 (let ((database (database-connect (list host "template1" user password)
455 (find name (database-query "select datname from pg_database"
457 :key #'car :test #'string-equal)
459 (database-disconnect database)))))
461 (defmethod database-describe-table ((database postgresql-socket-database)
464 (format nil "select a.attname, t.typname
465 from pg_class c, pg_attribute a, pg_type t
466 where c.relname = '~a'
468 and a.attrelid = c.oid
469 and a.atttypid = t.oid"
470 (sql-escape (string-downcase table)))
473 (when (clsql-base-sys:database-type-library-loaded :postgresql-socket)
474 (clsql-base-sys:initialize-database-type :database-type :postgresql-socket))