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.4 2002/03/24 18:31:05 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)
32 (defun tidy-error-message (message)
33 (unless (stringp message)
34 (setq message (uffi:convert-from-foreign-string message)))
35 (let ((message (string-right-trim '(#\Return #\Newline) message)))
37 ((< (length message) (length "ERROR:"))
39 ((string= message "ERROR:" :end1 6)
40 (string-left-trim '(#\Space) (subseq message 6)))
44 (defmethod database-initialize-database-type ((database-type
48 (uffi:def-type pgsql-conn-def pgsql-conn)
49 (uffi:def-type pgsql-result-def pgsql-result)
52 (defclass postgresql-database (database)
53 ((conn-ptr :accessor database-conn-ptr :initarg :conn-ptr
54 :type pgsql-conn-def)))
56 (defmethod database-name-from-spec (connection-spec (database-type
58 (check-connection-spec connection-spec database-type
59 (host db user password &optional port options tty))
60 (destructuring-bind (host db user password &optional port options tty)
62 (declare (ignore password options tty))
63 (concatenate 'string host (if port ":") (if port port) "/" db "/" user)))
66 (defmethod database-connect (connection-spec (database-type (eql :postgresql)))
67 (check-connection-spec connection-spec database-type
68 (host db user password &optional port options tty))
69 (destructuring-bind (host db user password &optional port options tty)
71 (uffi:with-cstrings ((host-native host)
73 (password-native password)
76 (options-native options)
78 (let ((connection (PQsetdbLogin host-native port-native
79 options-native tty-native
82 (declare (type pgsql-conn-def connection))
83 (when (not (eq (PQstatus connection)
84 pgsql-conn-status-type#connection-ok))
85 (error 'clsql-connect-error
86 :database-type database-type
87 :connection-spec connection-spec
88 :errno (PQstatus connection)
89 :error (tidy-error-message
90 (PQerrorMessage connection))))
91 (make-instance 'postgresql-database
92 :name (database-name-from-spec connection-spec
94 :conn-ptr connection)))))
97 (defmethod database-disconnect ((database postgresql-database))
98 (PQfinish (database-conn-ptr database))
99 (setf (database-conn-ptr database) nil)
102 (defmethod database-query (query-expression (database postgresql-database) field-types)
103 (let ((conn-ptr (database-conn-ptr database)))
104 (declare (type pgsql-conn-def conn-ptr))
105 (uffi:with-cstring (query-native query-expression)
106 (let ((result (PQexec conn-ptr query-native)))
107 (when (uffi:null-pointer-p result)
108 (error 'clsql-sql-error
110 :expression query-expression
112 :error (tidy-error-message (PQerrorMessage conn-ptr))))
114 (case (PQresultStatus result)
115 (#.pgsql-exec-status-type#empty-query
117 (#.pgsql-exec-status-type#tuples-ok
118 (loop for tuple-index from 0 below (PQntuples result)
120 (loop for i from 0 below (PQnfields result)
122 (if (zerop (PQgetisnull result tuple-index i))
123 (uffi:convert-from-cstring
124 (PQgetvalue result tuple-index i))
127 (error 'clsql-sql-error
129 :expression query-expression
130 :errno (PQresultStatus result)
131 :error (tidy-error-message
132 (PQresultErrorMessage result)))))
133 (PQclear result))))))
135 (defmethod database-execute-command (sql-expression
136 (database postgresql-database))
137 (let ((conn-ptr (database-conn-ptr database)))
138 (declare (type pgsql-conn-def conn-ptr))
139 (uffi:with-cstring (sql-native sql-expression)
140 (let ((result (PQexec conn-ptr sql-native)))
141 (when (uffi:null-pointer-p result)
142 (error 'clsql-sql-error
144 :expression sql-expression
146 :error (tidy-error-message (PQerrorMessage conn-ptr))))
148 (case (PQresultStatus result)
149 (#.pgsql-exec-status-type#command-ok
151 ((#.pgsql-exec-status-type#empty-query
152 #.pgsql-exec-status-type#tuples-ok)
153 (warn "Strange result...")
156 (error 'clsql-sql-error
158 :expression sql-expression
159 :errno (PQresultStatus result)
160 :error (tidy-error-message
161 (PQresultErrorMessage result)))))
162 (PQclear result))))))
164 (defstruct postgresql-result-set
165 (res-ptr (uffi:make-null-pointer 'pgsql-result)
166 :type pgsql-result-def)
167 (field-types nil :type cons)
168 (num-tuples 0 :type integer)
169 (num-fields 0 :type integer)
170 (tuple-index 0 :type integer))
172 (defmethod database-query-result-set (query-expression (database postgresql-database)
173 &key full-set field-types)
174 (let ((conn-ptr (database-conn-ptr database)))
175 (declare (type pgsql-conn-def conn-ptr))
176 (uffi:with-cstring (query-native query-expression)
177 (let ((result (PQexec conn-ptr query-native)))
178 (when (uffi:null-pointer-p result)
179 (error 'clsql-sql-error
181 :expression query-expression
183 :error (tidy-error-message (PQerrorMessage conn-ptr))))
184 (case (PQresultStatus result)
185 ((#.pgsql-exec-status-type#empty-query
186 #.pgsql-exec-status-type#tuples-ok)
188 (values (make-postgresql-result-set
190 :num-fields (PQnfields result)
191 :num-tuples (PQntuples result))
194 (values (make-postgresql-result-set
196 :num-fields (PQnfields result)
197 :num-tuples (PQntuples result))
198 (PQnfields result))))
201 (error 'clsql-sql-error
203 :expression query-expression
204 :errno (PQresultStatus result)
205 :error (tidy-error-message
206 (PQresultErrorMessage result)))
207 (PQclear result))))))))
209 (defmethod database-dump-result-set (result-set (database postgresql-database))
210 (let ((res-ptr (postgresql-result-set-res-ptr result-set)))
211 (declare (type pgsql-result-def res-ptr))
215 (defmethod database-store-next-row (result-set (database postgresql-database)
217 (let ((result (postgresql-result-set-res-ptr result-set)))
218 (declare (type pgsql-result-def result))
219 (if (>= (postgresql-result-set-tuple-index result-set)
220 (postgresql-result-set-num-tuples result-set))
222 (loop with tuple-index = (postgresql-result-set-tuple-index result-set)
223 for i from 0 below (postgresql-result-set-num-fields result-set)
227 (if (zerop (PQgetisnull result tuple-index i))
228 (uffi:convert-from-cstring
229 (PQgetvalue result tuple-index i))
232 (incf (postgresql-result-set-tuple-index result-set))