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
12 ;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg
13 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
15 ;;;; CLSQL users are granted the rights to distribute and use this software
16 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
17 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
18 ;;;; *************************************************************************
20 (in-package #:cl-user)
22 (defpackage :clsql-postgresql-socket
23 (:use #:common-lisp #:clsql-sys #:postgresql-socket)
24 (:export #:postgresql-socket-database)
25 (:documentation "This is the CLSQL socket interface to PostgreSQL."))
27 (in-package #:clsql-postgresql-socket)
29 ;; interface foreign library loading routines
32 (clsql-sys:database-type-load-foreign :postgresql-socket)
35 ;; Field type conversion
37 (defun make-type-list-for-auto (cursor)
38 (let* ((fields (postgresql-cursor-fields cursor))
39 (num-fields (length fields))
41 (dotimes (i num-fields)
43 (push (canonical-field-type fields i) new-types))
44 (nreverse new-types)))
46 (defun canonical-field-type (fields index)
47 "Extracts canonical field type from fields list"
48 (let ((oid (cadr (nth index fields))))
56 ((#.pgsql-ftype#float4
62 (defun canonicalize-types (types cursor)
65 (let ((auto-list (make-type-list-for-auto cursor)))
68 (canonicalize-type-list types auto-list))
74 (defun canonicalize-type-list (types auto-list)
75 "Ensure a field type list meets expectations.
76 Duplicated from clsql-uffi package so that this interface
77 doesn't depend on UFFI."
78 (let ((length-types (length types))
80 (loop for i from 0 below (length auto-list)
82 (if (>= i length-types)
83 (push t new-types) ;; types is shorted than num-fields
87 (case (nth i auto-list)
95 (case (nth i auto-list)
103 (nreverse new-types)))
106 (defun convert-to-clsql-warning (database condition)
107 (ecase *backend-warning-behavior*
109 (warn 'clsql-database-warning :database database
110 :message (postgresql-condition-message condition)))
112 (error 'clsql-sql-error :database database
113 :message (format nil "Warning upgraded to error: ~A"
114 (postgresql-condition-message condition))))
119 (defun convert-to-clsql-error (database expression condition)
120 (error 'clsql-sql-error :database database
121 :expression expression
122 :errno (type-of condition)
123 :error (postgresql-condition-message condition)))
125 (defmacro with-postgresql-handlers
126 ((database &optional expression)
128 (let ((database-var (gensym))
129 (expression-var (gensym)))
130 `(let ((,database-var ,database)
131 (,expression-var ,expression))
132 (handler-bind ((postgresql-warning
134 (convert-to-clsql-warning ,database-var c)))
137 (convert-to-clsql-error
138 ,database-var ,expression-var c))))
141 (defmethod database-initialize-database-type ((database-type
142 (eql :postgresql-socket)))
145 (defclass postgresql-socket-database (database)
146 ((connection :accessor database-connection :initarg :connection
147 :type postgresql-connection)))
149 (defmethod database-type ((database postgresql-socket-database))
152 (defmethod database-name-from-spec (connection-spec
153 (database-type (eql :postgresql-socket)))
154 (check-connection-spec connection-spec database-type
155 (host db user password &optional port options tty))
156 (destructuring-bind (host db user password &optional port options tty)
158 (declare (ignore password options tty))
163 (pathname (namestring host))
169 (integer (write-to-string port))
173 (defmethod database-connect (connection-spec
174 (database-type (eql :postgresql-socket)))
175 (check-connection-spec connection-spec database-type
176 (host db user password &optional port options tty))
177 (destructuring-bind (host db user password &optional
178 (port +postgresql-server-default-port+)
179 (options "") (tty ""))
182 (handler-bind ((postgresql-warning
184 (warn 'clsql-simple-warning
187 (list (princ-to-string c))))))
188 (open-postgresql-connection :host host :port port
189 :options options :tty tty
190 :database db :user user
192 (postgresql-error (c)
194 (error 'clsql-connect-error
195 :database-type database-type
196 :connection-spec connection-spec
198 :error (postgresql-condition-message c)))
199 (:no-error (connection)
200 ;; Success, make instance
201 (make-instance 'postgresql-socket-database
202 :name (database-name-from-spec connection-spec
204 :database-type :postgresql-socket
205 :connection-spec connection-spec
206 :connection connection)))))
208 (defmethod database-disconnect ((database postgresql-socket-database))
209 (close-postgresql-connection (database-connection database))
212 (defmethod database-query (expression (database postgresql-socket-database) result-types field-names)
213 (let ((connection (database-connection database)))
214 (with-postgresql-handlers (database expression)
215 (start-query-execution connection expression)
216 (multiple-value-bind (status cursor)
217 (wait-for-query-results connection)
218 (unless (eq status :cursor)
219 (close-postgresql-connection connection)
220 (error 'clsql-sql-error
222 :expression expression
223 :errno 'missing-result
224 :error "Didn't receive result cursor for query."))
225 (setq result-types (canonicalize-types result-types cursor))
227 (loop for row = (read-cursor-row cursor result-types)
231 (unless (null (wait-for-query-results connection))
232 (close-postgresql-connection connection)
233 (error 'clsql-sql-error
235 :expression expression
236 :errno 'multiple-results
237 :error "Received multiple results for query.")))
239 (mapcar #'car (postgresql-cursor-fields cursor))))))))
241 (defmethod database-execute-command
242 (expression (database postgresql-socket-database))
243 (let ((connection (database-connection database)))
244 (with-postgresql-handlers (database expression)
245 (start-query-execution connection expression)
246 (multiple-value-bind (status result)
247 (wait-for-query-results connection)
248 (when (eq status :cursor)
250 (multiple-value-bind (row stuff)
251 (skip-cursor-row result)
253 (setq status :completed result stuff)
258 ((eq status :completed)
259 (unless (null (wait-for-query-results connection))
260 (close-postgresql-connection connection)
261 (error 'clsql-sql-error
263 :expression expression
264 :errno 'multiple-results
265 :error "Received multiple results for command."))
268 (close-postgresql-connection connection)
269 (error 'clsql-sql-error
271 :expression expression
272 :errno 'missing-result
273 :error "Didn't receive completion for command.")))))))
275 (defstruct postgresql-socket-result-set
280 (defmethod database-query-result-set ((expression string)
281 (database postgresql-socket-database)
282 &key full-set result-types)
283 (declare (ignore full-set))
284 (let ((connection (database-connection database)))
285 (with-postgresql-handlers (database expression)
286 (start-query-execution connection expression)
287 (multiple-value-bind (status cursor)
288 (wait-for-query-results connection)
289 (unless (eq status :cursor)
290 (close-postgresql-connection connection)
291 (error 'clsql-sql-error
293 :expression expression
294 :errno 'missing-result
295 :error "Didn't receive result cursor for query."))
296 (values (make-postgresql-socket-result-set
299 :types (canonicalize-types result-types cursor))
300 (length (postgresql-cursor-fields cursor)))))))
302 (defmethod database-dump-result-set (result-set
303 (database postgresql-socket-database))
304 (if (postgresql-socket-result-set-done result-set)
306 (with-postgresql-handlers (database)
307 (loop while (skip-cursor-row
308 (postgresql-socket-result-set-cursor result-set))
309 finally (setf (postgresql-socket-result-set-done result-set) t)))))
311 (defmethod database-store-next-row (result-set
312 (database postgresql-socket-database)
314 (let ((cursor (postgresql-socket-result-set-cursor result-set)))
315 (with-postgresql-handlers (database)
316 (if (copy-cursor-row cursor
318 (postgresql-socket-result-set-types
322 (setf (postgresql-socket-result-set-done result-set) t)
323 (wait-for-query-results (database-connection database)))))))
327 (defun owner-clause (owner)
332 " AND (relowner=(SELECT usesysid FROM pg_user WHERE (usename='~A')))"
335 (format nil " AND (NOT (relowner=1))"))
338 (defun database-list-objects-of-type (database type owner)
342 "SELECT relname FROM pg_class WHERE (relkind = '~A')~A"
344 (owner-clause owner))
347 (defmethod database-list-tables ((database postgresql-socket-database)
349 (database-list-objects-of-type database "r" owner))
351 (defmethod database-list-views ((database postgresql-socket-database)
353 (database-list-objects-of-type database "v" owner))
355 (defmethod database-list-indexes ((database postgresql-socket-database)
357 (database-list-objects-of-type database "i" owner))
359 (defmethod database-list-table-indexes (table
360 (database postgresql-socket-database)
366 "select indexrelid from pg_index where indrelid=(select relfilenode from pg_class where relname='~A'~A)"
367 (string-downcase table)
368 (owner-clause owner))
371 (dolist (indexrelid indexrelids (nreverse result))
373 (caar (database-query
374 (format nil "select relname from pg_class where relfilenode='~A'"
379 (defmethod database-list-attributes ((table string)
380 (database postgresql-socket-database)
383 (cond ((stringp owner)
384 (format nil " AND (relowner=(SELECT usesysid FROM pg_user WHERE usename='~A'))" owner))
385 ((null owner) " AND (not (relowner=1))")
390 (format nil "SELECT attname FROM pg_class,pg_attribute WHERE pg_class.oid=attrelid AND relname='~A'~A"
391 (string-downcase table)
395 (remove-if #'(lambda (it) (member it '("cmin"
401 ;; kmr -- added tableoid
402 "tableoid") :test #'equal))
405 (defmethod database-attribute-type (attribute (table string)
406 (database postgresql-socket-database)
408 (let ((row (car (database-query
409 (format nil "SELECT pg_type.typname,pg_attribute.attlen,pg_attribute.atttypmod,pg_attribute.attnotnull 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"
410 (string-downcase table)
411 (string-downcase attribute)
412 (owner-clause owner))
416 (ensure-keyword (first row))
417 (if (string= "-1" (second row))
418 (- (parse-integer (third row) :junk-allowed t) 4)
419 (parse-integer (second row)))
421 (if (string-equal "f" (fourth row))
425 (defmethod database-create-sequence (sequence-name
426 (database postgresql-socket-database))
427 (database-execute-command
428 (concatenate 'string "CREATE SEQUENCE " (sql-escape sequence-name))
431 (defmethod database-drop-sequence (sequence-name
432 (database postgresql-socket-database))
433 (database-execute-command
434 (concatenate 'string "DROP SEQUENCE " (sql-escape sequence-name)) database))
436 (defmethod database-list-sequences ((database postgresql-socket-database)
438 (database-list-objects-of-type database "S" owner))
440 (defmethod database-set-sequence-position (name (position integer)
441 (database postgresql-socket-database))
446 (format nil "SELECT SETVAL ('~A', ~A)" name position)
447 database nil nil)))))
449 (defmethod database-sequence-next (sequence-name
450 (database postgresql-socket-database))
455 (concatenate 'string "SELECT NEXTVAL ('" (sql-escape sequence-name) "')")
456 database nil nil)))))
458 (defmethod database-sequence-last (sequence-name (database postgresql-socket-database))
463 (concatenate 'string "SELECT LAST_VALUE ('" sequence-name "')")
464 database nil nil)))))
467 (defmethod database-create (connection-spec (type (eql :postgresql-socket)))
468 (destructuring-bind (host name user password) connection-spec
469 (let ((database (database-connect (list host "template1" user password)
472 (execute-command (format nil "create database ~A" name))
473 (database-disconnect database)))))
475 (defmethod database-destroy (connection-spec (type (eql :postgresql-socket)))
476 (destructuring-bind (host name user password) connection-spec
477 (let ((database (database-connect (list host "template1" user password)
480 (execute-command (format nil "drop database ~A" name))
481 (database-disconnect database)))))
484 (defmethod database-probe (connection-spec (type (eql :postgresql-socket)))
485 (when (find (second connection-spec) (database-list connection-spec type)
486 :key #'car :test #'string-equal)
489 (defmethod database-list (connection-spec (type (eql :postgresql-socket)))
490 (destructuring-bind (host name user password) connection-spec
491 (declare (ignore name))
492 (let ((database (database-connect (list host "template1" user password)
496 (setf (slot-value database 'clsql-sys::state) :open)
497 (mapcar #'car (database-query "select datname from pg_database"
498 database :auto nil)))
500 (database-disconnect database)
501 (setf (slot-value database 'clsql-sys::state) :closed))))))
503 (defmethod database-describe-table ((database postgresql-socket-database)
506 (format nil "select a.attname, t.typname
507 from pg_class c, pg_attribute a, pg_type t
508 where c.relname = '~a'
510 and a.attrelid = c.oid
511 and a.atttypid = t.oid"
512 (sql-escape (string-downcase table)))
516 ;; Database capabilities
518 (defmethod db-backend-has-create/destroy-db? ((db-type (eql :postgresql-socket)))
521 (defmethod db-type-has-fancy-math? ((db-type (eql :postgresql-socket)))
524 (defmethod db-type-default-case ((db-type (eql :postgresql-socket)))
527 (when (clsql-sys:database-type-library-loaded :postgresql-socket)
528 (clsql-sys:initialize-database-type :database-type :postgresql-socket))