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.12 2002/03/29 09:37:24 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 :clsql-uffi)
26 (:export #:postgresql-database)
27 (:documentation "This is the CLSQL interface to PostgreSQL."))
29 (in-package :clsql-postgresql)
31 ;;; Field conversion functions
33 (defun make-type-list-for-auto (num-fields res-ptr)
34 (let ((new-types '()))
35 (dotimes (i num-fields)
37 (let* ((type (PQftype res-ptr i)))
46 ((#.pgsql-ftype#float4
52 (nreverse new-types)))
54 (defun canonicalize-types (types num-fields res-ptr)
57 (let ((auto-list (make-type-list-for-auto num-fields res-ptr)))
60 (canonicalize-type-list types auto-list))
66 (defun tidy-error-message (message)
67 (unless (stringp message)
68 (setq message (uffi:convert-from-foreign-string message)))
69 (let ((message (string-right-trim '(#\Return #\Newline) message)))
71 ((< (length message) (length "ERROR:"))
73 ((string= message "ERROR:" :end1 6)
74 (string-left-trim '(#\Space) (subseq message 6)))
78 (defmethod database-initialize-database-type ((database-type
82 (uffi:def-type pgsql-conn-def pgsql-conn)
83 (uffi:def-type pgsql-result-def pgsql-result)
86 (defclass postgresql-database (database)
87 ((conn-ptr :accessor database-conn-ptr :initarg :conn-ptr
88 :type pgsql-conn-def)))
90 (defmethod database-name-from-spec (connection-spec (database-type
92 (check-connection-spec connection-spec database-type
93 (host db user password &optional port options tty))
94 (destructuring-bind (host db user password &optional port options tty)
96 (declare (ignore password options tty))
97 (concatenate 'string host (if port ":") (if port port) "/" db "/" user)))
100 (defmethod database-connect (connection-spec (database-type (eql :postgresql)))
101 (check-connection-spec connection-spec database-type
102 (host db user password &optional port options tty))
103 (destructuring-bind (host db user password &optional port options tty)
105 (uffi:with-cstrings ((host-native host)
107 (password-native password)
110 (options-native options)
112 (let ((connection (PQsetdbLogin host-native port-native
113 options-native tty-native
114 db-native user-native
116 (declare (type pgsql-conn-def connection))
117 (when (not (eq (PQstatus connection)
118 pgsql-conn-status-type#connection-ok))
119 (error 'clsql-connect-error
120 :database-type database-type
121 :connection-spec connection-spec
122 :errno (PQstatus connection)
123 :error (tidy-error-message
124 (PQerrorMessage connection))))
125 (make-instance 'postgresql-database
126 :name (database-name-from-spec connection-spec
128 :conn-ptr connection)))))
131 (defmethod database-disconnect ((database postgresql-database))
132 (PQfinish (database-conn-ptr database))
133 (setf (database-conn-ptr database) nil)
136 (defmethod database-query (query-expression (database postgresql-database) types)
137 (let ((conn-ptr (database-conn-ptr database)))
138 (declare (type pgsql-conn-def conn-ptr))
139 (uffi:with-cstring (query-native query-expression)
140 (let ((result (PQexec conn-ptr query-native)))
141 (when (uffi:null-pointer-p result)
142 (error 'clsql-sql-error
144 :expression query-expression
146 :error (tidy-error-message (PQerrorMessage conn-ptr))))
148 (case (PQresultStatus result)
149 (#.pgsql-exec-status-type#empty-query
151 (#.pgsql-exec-status-type#tuples-ok
152 (let ((num-fields (PQnfields result)))
154 (canonicalize-types types num-fields
156 (loop for tuple-index from 0 below (PQntuples result)
158 (loop for i from 0 below num-fields
160 (if (zerop (PQgetisnull result tuple-index i))
162 (PQgetvalue result tuple-index i)
166 (error 'clsql-sql-error
168 :expression query-expression
169 :errno (PQresultStatus result)
170 :error (tidy-error-message
171 (PQresultErrorMessage result)))))
172 (PQclear result))))))
174 (defmethod database-execute-command (sql-expression
175 (database postgresql-database))
176 (let ((conn-ptr (database-conn-ptr database)))
177 (declare (type pgsql-conn-def conn-ptr))
178 (uffi:with-cstring (sql-native sql-expression)
179 (let ((result (PQexec conn-ptr sql-native)))
180 (when (uffi:null-pointer-p result)
181 (error 'clsql-sql-error
183 :expression sql-expression
185 :error (tidy-error-message (PQerrorMessage conn-ptr))))
187 (case (PQresultStatus result)
188 (#.pgsql-exec-status-type#command-ok
190 ((#.pgsql-exec-status-type#empty-query
191 #.pgsql-exec-status-type#tuples-ok)
192 (warn "Strange result...")
195 (error 'clsql-sql-error
197 :expression sql-expression
198 :errno (PQresultStatus result)
199 :error (tidy-error-message
200 (PQresultErrorMessage result)))))
201 (PQclear result))))))
203 (defstruct postgresql-result-set
204 (res-ptr (uffi:make-null-pointer 'pgsql-result)
205 :type pgsql-result-def)
207 (num-tuples 0 :type integer)
208 (num-fields 0 :type integer)
209 (tuple-index 0 :type integer))
211 (defmethod database-query-result-set (query-expression (database postgresql-database)
213 (let ((conn-ptr (database-conn-ptr database)))
214 (declare (type pgsql-conn-def conn-ptr))
215 (uffi:with-cstring (query-native query-expression)
216 (let ((result (PQexec conn-ptr query-native)))
217 (when (uffi:null-pointer-p result)
218 (error 'clsql-sql-error
220 :expression query-expression
222 :error (tidy-error-message (PQerrorMessage conn-ptr))))
223 (case (PQresultStatus result)
224 ((#.pgsql-exec-status-type#empty-query
225 #.pgsql-exec-status-type#tuples-ok)
226 (let ((result-set (make-postgresql-result-set
228 :num-fields (PQnfields result)
229 :num-tuples (PQntuples result)
230 :types (canonicalize-types
239 (PQnfields result)))))
242 (error 'clsql-sql-error
244 :expression query-expression
245 :errno (PQresultStatus result)
246 :error (tidy-error-message
247 (PQresultErrorMessage result)))
248 (PQclear result))))))))
250 (defmethod database-dump-result-set (result-set (database postgresql-database))
251 (let ((res-ptr (postgresql-result-set-res-ptr result-set)))
252 (declare (type pgsql-result-def res-ptr))
256 (defmethod database-store-next-row (result-set (database postgresql-database)
258 (let ((result (postgresql-result-set-res-ptr result-set))
259 (types (postgresql-result-set-types result-set)))
260 (declare (type pgsql-result-def result))
261 (if (>= (postgresql-result-set-tuple-index result-set)
262 (postgresql-result-set-num-tuples result-set))
264 (loop with tuple-index = (postgresql-result-set-tuple-index result-set)
265 for i from 0 below (postgresql-result-set-num-fields result-set)
269 (if (zerop (PQgetisnull result tuple-index i))
271 (PQgetvalue result tuple-index i)
275 (incf (postgresql-result-set-tuple-index result-set))