1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: postgresql-sql.sql
6 ;;;; Purpose: High-level PostgreSQL interface using UFFI
7 ;;;; Programmers: Kevin M. Rosenberg based on
8 ;;;; Original code by Pierre R. Mai
9 ;;;; Date Started: Feb 2002
11 ;;;; $Id: postgresql-sql.cl,v 1.7 2002/03/25 06:07:06 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
25 (:use :common-lisp :clsql-sys :postgresql)
26 (:export #:postgresql-database)
27 (:documentation "This is the CLSQL interface to PostgreSQL."))
29 (in-package :clsql-postgresql)
31 ;;; Field conversion functions
33 (defun canonicalize-field-types (types num-fields)
35 (let ((length-types (length types))
37 (loop for i from 0 below num-fields
39 (if (>= i length-types)
40 (push t new-types) ;; types is shorted than num-fields
43 ((:int :long :double t)
53 (uffi:def-function "atoi"
57 (uffi:def-function "atol"
61 (uffi:def-function "atof"
65 (defun convert-raw-field (char-ptr types index)
66 (let ((type (if (listp types)
77 (uffi:convert-from-foreign-string char-ptr)))))
80 (defun tidy-error-message (message)
81 (unless (stringp message)
82 (setq message (uffi:convert-from-foreign-string message)))
83 (let ((message (string-right-trim '(#\Return #\Newline) message)))
85 ((< (length message) (length "ERROR:"))
87 ((string= message "ERROR:" :end1 6)
88 (string-left-trim '(#\Space) (subseq message 6)))
92 (defmethod database-initialize-database-type ((database-type
96 (uffi:def-type pgsql-conn-def pgsql-conn)
97 (uffi:def-type pgsql-result-def pgsql-result)
100 (defclass postgresql-database (database)
101 ((conn-ptr :accessor database-conn-ptr :initarg :conn-ptr
102 :type pgsql-conn-def)))
104 (defmethod database-name-from-spec (connection-spec (database-type
106 (check-connection-spec connection-spec database-type
107 (host db user password &optional port options tty))
108 (destructuring-bind (host db user password &optional port options tty)
110 (declare (ignore password options tty))
111 (concatenate 'string host (if port ":") (if port port) "/" db "/" user)))
114 (defmethod database-connect (connection-spec (database-type (eql :postgresql)))
115 (check-connection-spec connection-spec database-type
116 (host db user password &optional port options tty))
117 (destructuring-bind (host db user password &optional port options tty)
119 (uffi:with-cstrings ((host-native host)
121 (password-native password)
124 (options-native options)
126 (let ((connection (PQsetdbLogin host-native port-native
127 options-native tty-native
128 db-native user-native
130 (declare (type pgsql-conn-def connection))
131 (when (not (eq (PQstatus connection)
132 pgsql-conn-status-type#connection-ok))
133 (error 'clsql-connect-error
134 :database-type database-type
135 :connection-spec connection-spec
136 :errno (PQstatus connection)
137 :error (tidy-error-message
138 (PQerrorMessage connection))))
139 (make-instance 'postgresql-database
140 :name (database-name-from-spec connection-spec
142 :conn-ptr connection)))))
145 (defmethod database-disconnect ((database postgresql-database))
146 (PQfinish (database-conn-ptr database))
147 (setf (database-conn-ptr database) nil)
150 (defmethod database-query (query-expression (database postgresql-database) field-types)
151 (let ((conn-ptr (database-conn-ptr database)))
152 (declare (type pgsql-conn-def conn-ptr))
153 (uffi:with-cstring (query-native query-expression)
154 (let ((result (PQexec conn-ptr query-native)))
155 (when (uffi:null-pointer-p result)
156 (error 'clsql-sql-error
158 :expression query-expression
160 :error (tidy-error-message (PQerrorMessage conn-ptr))))
162 (case (PQresultStatus result)
163 (#.pgsql-exec-status-type#empty-query
165 (#.pgsql-exec-status-type#tuples-ok
166 (let ((num-fields (PQnfields result)))
168 (canonicalize-field-types field-types num-fields))
169 (loop for tuple-index from 0 below (PQntuples result)
171 (loop for i from 0 below num-fields
173 (if (zerop (PQgetisnull result tuple-index i))
175 (PQgetvalue result tuple-index i)
179 (error 'clsql-sql-error
181 :expression query-expression
182 :errno (PQresultStatus result)
183 :error (tidy-error-message
184 (PQresultErrorMessage result)))))
185 (PQclear result))))))
187 (defmethod database-execute-command (sql-expression
188 (database postgresql-database))
189 (let ((conn-ptr (database-conn-ptr database)))
190 (declare (type pgsql-conn-def conn-ptr))
191 (uffi:with-cstring (sql-native sql-expression)
192 (let ((result (PQexec conn-ptr sql-native)))
193 (when (uffi:null-pointer-p result)
194 (error 'clsql-sql-error
196 :expression sql-expression
198 :error (tidy-error-message (PQerrorMessage conn-ptr))))
200 (case (PQresultStatus result)
201 (#.pgsql-exec-status-type#command-ok
203 ((#.pgsql-exec-status-type#empty-query
204 #.pgsql-exec-status-type#tuples-ok)
205 (warn "Strange result...")
208 (error 'clsql-sql-error
210 :expression sql-expression
211 :errno (PQresultStatus result)
212 :error (tidy-error-message
213 (PQresultErrorMessage result)))))
214 (PQclear result))))))
216 (defstruct postgresql-result-set
217 (res-ptr (uffi:make-null-pointer 'pgsql-result)
218 :type pgsql-result-def)
220 (num-tuples 0 :type integer)
221 (num-fields 0 :type integer)
222 (tuple-index 0 :type integer))
224 (defmethod database-query-result-set (query-expression (database postgresql-database)
225 &key full-set field-types)
226 (let ((conn-ptr (database-conn-ptr database)))
227 (declare (type pgsql-conn-def conn-ptr))
228 (uffi:with-cstring (query-native query-expression)
229 (let ((result (PQexec conn-ptr query-native)))
230 (when (uffi:null-pointer-p result)
231 (error 'clsql-sql-error
233 :expression query-expression
235 :error (tidy-error-message (PQerrorMessage conn-ptr))))
236 (case (PQresultStatus result)
237 ((#.pgsql-exec-status-type#empty-query
238 #.pgsql-exec-status-type#tuples-ok)
239 (let ((result-set (make-postgresql-result-set
241 :num-fields (PQnfields result)
242 :num-tuples (PQntuples result)
243 :field-types (canonicalize-field-types
245 (PQnfields result)))))
251 (PQnfields result)))))
254 (error 'clsql-sql-error
256 :expression query-expression
257 :errno (PQresultStatus result)
258 :error (tidy-error-message
259 (PQresultErrorMessage result)))
260 (PQclear result))))))))
262 (defmethod database-dump-result-set (result-set (database postgresql-database))
263 (let ((res-ptr (postgresql-result-set-res-ptr result-set)))
264 (declare (type pgsql-result-def res-ptr))
268 (defmethod database-store-next-row (result-set (database postgresql-database)
270 (let ((result (postgresql-result-set-res-ptr result-set))
271 (field-types (postgresql-result-set-field-types result-set)))
272 (declare (type pgsql-result-def result))
273 (if (>= (postgresql-result-set-tuple-index result-set)
274 (postgresql-result-set-num-tuples result-set))
276 (loop with tuple-index = (postgresql-result-set-tuple-index result-set)
277 for i from 0 below (postgresql-result-set-num-fields result-set)
281 (if (zerop (PQgetisnull result tuple-index i))
283 (PQgetvalue result tuple-index i)
287 (incf (postgresql-result-set-tuple-index result-set))