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-base-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-base-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 (warn 'clsql-database-warning :database database
108 :message (postgresql-condition-message condition)))
110 (defun convert-to-clsql-error (database expression condition)
111 (error 'clsql-sql-error :database database
112 :expression expression
113 :errno (type-of condition)
114 :error (postgresql-condition-message condition)))
116 (defmacro with-postgresql-handlers
117 ((database &optional expression)
119 (let ((database-var (gensym))
120 (expression-var (gensym)))
121 `(let ((,database-var ,database)
122 (,expression-var ,expression))
123 (handler-bind ((postgresql-warning
125 (convert-to-clsql-warning ,database-var c)))
128 (convert-to-clsql-error
129 ,database-var ,expression-var c))))
130 ;; KMR - removed double @@
133 (defmethod database-initialize-database-type ((database-type
134 (eql :postgresql-socket)))
137 (defclass postgresql-socket-database (database)
138 ((connection :accessor database-connection :initarg :connection
139 :type postgresql-connection)))
141 (defmethod database-type ((database postgresql-socket-database))
144 (defmethod database-name-from-spec (connection-spec
145 (database-type (eql :postgresql-socket)))
146 (check-connection-spec connection-spec database-type
147 (host db user password &optional port options tty))
148 (destructuring-bind (host db user password &optional port options tty)
150 (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 :database-type :postgresql-socket
197 :connection-spec connection-spec
198 :connection connection)))))
200 (defmethod database-disconnect ((database postgresql-socket-database))
201 (close-postgresql-connection (database-connection database))
204 (defmethod database-query (expression (database postgresql-socket-database) result-types field-names)
205 (let ((connection (database-connection database)))
206 (with-postgresql-handlers (database expression)
207 (start-query-execution connection expression)
208 (multiple-value-bind (status cursor)
209 (wait-for-query-results connection)
210 (unless (eq status :cursor)
211 (close-postgresql-connection connection)
212 (error 'clsql-sql-error
214 :expression expression
215 :errno 'missing-result
216 :error "Didn't receive result cursor for query."))
217 (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 (mapcar #'car (postgresql-cursor-fields cursor))))))))
233 (defmethod database-execute-command
234 (expression (database postgresql-socket-database))
235 (let ((connection (database-connection database)))
236 (with-postgresql-handlers (database expression)
237 (start-query-execution connection expression)
238 (multiple-value-bind (status result)
239 (wait-for-query-results connection)
240 (when (eq status :cursor)
242 (multiple-value-bind (row stuff)
243 (skip-cursor-row result)
245 (setq status :completed result stuff)
250 ((eq status :completed)
251 (unless (null (wait-for-query-results connection))
252 (close-postgresql-connection connection)
253 (error 'clsql-sql-error
255 :expression expression
256 :errno 'multiple-results
257 :error "Received multiple results for command."))
260 (close-postgresql-connection connection)
261 (error 'clsql-sql-error
263 :expression expression
264 :errno 'missing-result
265 :error "Didn't receive completion for command.")))))))
267 (defstruct postgresql-socket-result-set
272 (defmethod database-query-result-set ((expression string)
273 (database postgresql-socket-database)
274 &key full-set result-types)
275 (declare (ignore full-set))
276 (let ((connection (database-connection database)))
277 (with-postgresql-handlers (database expression)
278 (start-query-execution connection expression)
279 (multiple-value-bind (status cursor)
280 (wait-for-query-results connection)
281 (unless (eq status :cursor)
282 (close-postgresql-connection connection)
283 (error 'clsql-sql-error
285 :expression expression
286 :errno 'missing-result
287 :error "Didn't receive result cursor for query."))
288 (values (make-postgresql-socket-result-set
291 :types (canonicalize-types result-types cursor))
292 (length (postgresql-cursor-fields cursor)))))))
294 (defmethod database-dump-result-set (result-set
295 (database postgresql-socket-database))
296 (if (postgresql-socket-result-set-done result-set)
298 (with-postgresql-handlers (database)
299 (loop while (skip-cursor-row
300 (postgresql-socket-result-set-cursor result-set))
301 finally (setf (postgresql-socket-result-set-done result-set) t)))))
303 (defmethod database-store-next-row (result-set
304 (database postgresql-socket-database)
306 (let ((cursor (postgresql-socket-result-set-cursor result-set)))
307 (with-postgresql-handlers (database)
308 (if (copy-cursor-row cursor
310 (postgresql-socket-result-set-types
314 (setf (postgresql-socket-result-set-done result-set) t)
315 (wait-for-query-results (database-connection database)))))))
319 (defun owner-clause (owner)
324 " AND (relowner=(SELECT usesysid FROM pg_user WHERE (usename='~A')))"
327 (format nil " AND (NOT (relowner=1))"))
330 (defun database-list-objects-of-type (database type owner)
334 "SELECT relname FROM pg_class WHERE (relkind = '~A')~A"
336 (owner-clause owner))
339 (defmethod database-list-tables ((database postgresql-socket-database)
341 (database-list-objects-of-type database "r" owner))
343 (defmethod database-list-views ((database postgresql-socket-database)
345 (database-list-objects-of-type database "v" owner))
347 (defmethod database-list-indexes ((database postgresql-socket-database)
349 (database-list-objects-of-type database "i" owner))
351 (defmethod database-list-table-indexes (table
352 (database postgresql-socket-database)
358 "select indexrelid from pg_index where indrelid=(select relfilenode from pg_class where relname='~A'~A)"
359 (string-downcase table)
360 (owner-clause owner))
363 (dolist (indexrelid indexrelids (nreverse result))
365 (caar (database-query
366 (format nil "select relname from pg_class where relfilenode='~A'"
371 (defmethod database-list-attributes ((table string)
372 (database postgresql-socket-database)
375 (cond ((stringp owner)
376 (format nil " AND (relowner=(SELECT usesysid FROM pg_user WHERE usename='~A'))" owner))
377 ((null owner) " AND (not (relowner=1))")
382 (format nil "SELECT attname FROM pg_class,pg_attribute WHERE pg_class.oid=attrelid AND relname='~A'~A"
383 (string-downcase table)
388 (remove-if #'(lambda (it) (member it '("cmin"
394 ;; kmr -- added tableoid
395 "tableoid") :test #'equal))
398 (defmethod database-attribute-type (attribute (table string)
399 (database postgresql-socket-database)
401 (let ((row (car (database-query
402 (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"
403 (string-downcase table)
404 (string-downcase attribute)
405 (owner-clause owner))
409 (ensure-keyword (first row))
410 (if (string= "-1" (second row))
411 (- (parse-integer (third row) :junk-allowed t) 4)
412 (parse-integer (second row)))
414 (if (string-equal "f" (fourth row))
418 (defmethod database-create-sequence (sequence-name
419 (database postgresql-socket-database))
420 (database-execute-command
421 (concatenate 'string "CREATE SEQUENCE " (sql-escape sequence-name))
424 (defmethod database-drop-sequence (sequence-name
425 (database postgresql-socket-database))
426 (database-execute-command
427 (concatenate 'string "DROP SEQUENCE " (sql-escape sequence-name)) database))
429 (defmethod database-list-sequences ((database postgresql-socket-database)
431 (database-list-objects-of-type database "S" owner))
433 (defmethod database-set-sequence-position (name (position integer)
434 (database postgresql-socket-database))
439 (format nil "SELECT SETVAL ('~A', ~A)" name position)
440 database nil nil)))))
442 (defmethod database-sequence-next (sequence-name
443 (database postgresql-socket-database))
448 (concatenate 'string "SELECT NEXTVAL ('" (sql-escape sequence-name) "')")
449 database nil nil)))))
451 (defmethod database-sequence-last (sequence-name (database postgresql-socket-database))
456 (concatenate 'string "SELECT LAST_VALUE ('" sequence-name "')")
457 database nil nil)))))
460 (defmethod database-create (connection-spec (type (eql :postgresql-socket)))
461 (destructuring-bind (host name user password) connection-spec
462 (let ((database (database-connect (list host "template1" user password)
465 (execute-command (format nil "create database ~A" name))
466 (database-disconnect database)))))
468 (defmethod database-destroy (connection-spec (type (eql :postgresql-socket)))
469 (destructuring-bind (host name user password) connection-spec
470 (let ((database (database-connect (list host "template1" user password)
473 (execute-command (format nil "drop database ~A" name))
474 (database-disconnect database)))))
477 (defmethod database-probe (connection-spec (type (eql :postgresql-socket)))
478 (when (find (second connection-spec) (database-list connection-spec type)
479 :key #'car :test #'string-equal)
482 (defmethod database-list (connection-spec (type (eql :postgresql-socket)))
483 (destructuring-bind (host name user password) connection-spec
484 (declare (ignore name))
485 (let ((database (database-connect (list host "template1" user password)
489 (setf (slot-value database 'clsql-base-sys::state) :open)
490 (mapcar #'car (database-query "select datname from pg_database"
491 database :auto nil)))
493 (database-disconnect database)
494 (setf (slot-value database 'clsql-base-sys::state) :closed))))))
496 (defmethod database-describe-table ((database postgresql-socket-database)
499 (format nil "select a.attname, t.typname
500 from pg_class c, pg_attribute a, pg_type t
501 where c.relname = '~a'
503 and a.attrelid = c.oid
504 and a.atttypid = t.oid"
505 (sql-escape (string-downcase table)))
509 ;; Database capabilities
511 (defmethod db-backend-has-create/destroy-db? ((db-type (eql :postgresql-socket)))
514 (defmethod db-type-has-fancy-math? ((db-type (eql :postgresql-socket)))
517 (defmethod db-type-default-case ((db-type (eql :postgresql-socket)))
520 (when (clsql-base-sys:database-type-library-loaded :postgresql-socket)
521 (clsql-base-sys:initialize-database-type :database-type :postgresql-socket))