1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: mysql-sql.cl
6 ;;;; Purpose: High-level MySQL interface using UFFI
7 ;;;; Programmers: Kevin M. Rosenberg based on
8 ;;;; Original code by Pierre R. Mai
9 ;;;; Date Started: Feb 2002
11 ;;;; $Id: mysql-sql.cl,v 1.13 2002/03/27 05:37:35 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)))
23 ;;;; Modified by Kevin Rosenberg, Feb 20002
24 ;;;; -- Added support for Allegro CL and Lispworks using UFFI layer
25 ;;;; -- Changed database-connect to use mysql-real-connect. This way,
26 ;;;; can avoid using double (unwind-protect)
27 ;;;; -- Changed database-connect to have MySQL library allocate space
28 ;;;; for MYSQL structure. This will make the code more robust in
29 ;;;; the event that MySQL library changes the size of the mysql-mysql
33 ;;;; Added field types
35 (defpackage :clsql-mysql
36 (:use :common-lisp :clsql-sys :mysql)
37 (:export #:mysql-database)
38 (:documentation "This is the CLSQL interface to MySQL."))
40 (in-package :clsql-mysql)
42 ;;; Field conversion functions
44 (defun canonicalize-types (types num-fields res-ptr)
47 (let ((length-types (length types))
49 (loop for i from 0 below num-fields
51 (if (>= i length-types)
52 (push t new-types) ;; types is shorted than num-fields
55 ((:int :long :double t)
60 (nreverse new-types))))
63 #+ignore (field-vec (mysql-fetch-fields res-ptr)))
64 (dotimes (i num-fields)
66 (let* ( (field (mysql-fetch-field-direct res-ptr i))
67 #+ignore (field (uffi:deref-array field-vec 'mysql-field-vector i))
68 (type (uffi:get-slot-value field 'mysql-field 'type)))
71 ((#.mysql-field-types#tiny
72 #.mysql-field-types#short
73 #.mysql-field-types#int24
74 #.mysql-field-types#long)
76 (#.mysql-field-types#longlong
78 ((#.mysql-field-types#double
79 #.mysql-field-types#float
80 #.mysql-field-types#decimal)
85 (nreverse new-types)))
89 (uffi:def-function "atoi"
90 ((str (* :unsigned-char)))
93 (uffi:def-function "atol"
94 ((str (* :unsigned-char)))
97 (uffi:def-function "atol64"
98 ((str (* :unsigned-char))
102 (uffi:def-function "atof"
103 ((str (* :unsigned-char)))
106 (defun convert-raw-field (char-ptr types index)
107 (let ((type (if (listp types)
118 (uffi:with-foreign-object (high32-ptr :int)
119 (let ((low32 (atol64 char-ptr high32-ptr))
120 (high32 (uffi:deref-pointer high32-ptr :int)))
123 (mysql:make-64-bit-integer high32 low32)))))
125 (uffi:convert-from-foreign-string char-ptr)))))
127 (defmethod database-initialize-database-type ((database-type (eql :mysql)))
130 (uffi:def-type mysql-mysql-ptr-def (* mysql-mysql))
131 (uffi:def-type mysql-row-def mysql-row)
132 (uffi:def-type mysql-mysql-res-ptr-def (* mysql-mysql-res))
134 (defclass mysql-database (database)
135 ((mysql-ptr :accessor database-mysql-ptr :initarg :mysql-ptr
136 :type mysql-mysql-ptr-def)))
138 (defmethod database-name-from-spec (connection-spec (database-type (eql :mysql)))
139 (check-connection-spec connection-spec database-type (host db user password))
140 (destructuring-bind (host db user password) connection-spec
141 (declare (ignore password))
142 (concatenate 'string host "/" db "/" user)))
145 (defmethod database-connect (connection-spec (database-type (eql :mysql)))
146 (check-connection-spec connection-spec database-type (host db user password))
147 (destructuring-bind (host db user password) connection-spec
148 (let ((mysql-ptr (mysql-init (uffi:make-null-pointer 'mysql-mysql)))
150 (if (uffi:null-pointer-p mysql-ptr)
151 (error 'clsql-connect-error
152 :database-type database-type
153 :connection-spec connection-spec
154 :errno (mysql-errno mysql-ptr)
155 :error (mysql-error-string mysql-ptr))
156 (uffi:with-cstrings ((host-native host)
158 (password-native password)
160 (socket-native socket))
161 (let ((error-occurred nil))
163 (if (uffi:null-pointer-p
165 mysql-ptr host-native user-native password-native
166 db-native 0 socket-native 0))
168 (setq error-occurred t)
169 (error 'clsql-connect-error
170 :database-type database-type
171 :connection-spec connection-spec
172 :errno (mysql-errno mysql-ptr)
173 :error (mysql-error-string mysql-ptr)))
174 (make-instance 'mysql-database
175 :name (database-name-from-spec connection-spec
177 :mysql-ptr mysql-ptr))
178 (when error-occurred (mysql-close mysql-ptr)))))))))
181 (defmethod database-disconnect ((database mysql-database))
182 (mysql-close (database-mysql-ptr database))
183 (setf (database-mysql-ptr database) nil)
187 (defmethod database-query (query-expression (database mysql-database)
189 (with-slots (mysql-ptr) database
190 (uffi:with-cstring (query-native query-expression)
191 (if (zerop (mysql-query mysql-ptr query-native))
192 (let ((res-ptr (mysql-use-result mysql-ptr)))
194 (let ((num-fields (mysql-num-fields res-ptr)))
195 (setq types (canonicalize-types
199 (loop for row = (mysql-fetch-row res-ptr)
200 until (uffi:null-pointer-p row)
202 (loop for i from 0 below num-fields
205 (uffi:deref-array row 'mysql-row i)
207 (mysql-free-result res-ptr)))
208 (error 'clsql-sql-error
210 :expression query-expression
211 :errno (mysql-errno mysql-ptr)
212 :error (mysql-error-string mysql-ptr))))
213 (error 'clsql-sql-error
215 :expression query-expression
216 :errno (mysql-errno mysql-ptr)
217 :error (mysql-error-string mysql-ptr))))))
219 (defmethod database-execute-command (sql-expression (database mysql-database))
220 (uffi:with-cstring (sql-native sql-expression)
221 (let ((mysql-ptr (database-mysql-ptr database)))
222 (declare (type mysql-mysql-ptr-def mysql-ptr))
223 (if (zerop (mysql-query mysql-ptr sql-native))
225 (error 'clsql-sql-error
227 :expression sql-expression
228 :errno (mysql-errno mysql-ptr)
229 :error (mysql-error-string mysql-ptr))))))
231 (defstruct mysql-result-set
232 (res-ptr (uffi:make-null-pointer 'mysql-mysql-res)
233 :type mysql-mysql-res-ptr-def)
235 (num-fields nil :type fixnum)
236 (full-set nil :type boolean))
239 (defmethod database-query-result-set (query-expression
240 (database mysql-database)
242 (uffi:with-cstring (query-native query-expression)
243 (let ((mysql-ptr (database-mysql-ptr database)))
244 (declare (type mysql-mysql-ptr-def mysql-ptr))
245 (if (zerop (mysql-query mysql-ptr query-native))
246 (let ((res-ptr (if full-set
247 (mysql-store-result mysql-ptr)
248 (mysql-use-result mysql-ptr))))
249 (declare (type mysql-mysql-res-ptr-def res-ptr))
250 (if (not (uffi:null-pointer-p res-ptr))
251 (let* ((num-fields (mysql-num-fields res-ptr))
252 (result-set (make-mysql-result-set
254 :num-fields num-fields
263 (mysql-num-rows res-ptr))
266 (error 'clsql-sql-error
268 :expression query-expression
269 :errno (mysql-errno mysql-ptr)
270 :error (mysql-error-string mysql-ptr))))
271 (error 'clsql-sql-error
273 :expression query-expression
274 :errno (mysql-errno mysql-ptr)
275 :error (mysql-error-string mysql-ptr))))))
277 (defmethod database-dump-result-set (result-set (database mysql-database))
278 (mysql-free-result (mysql-result-set-res-ptr result-set))
283 (defmethod database-store-next-row (result-set (database mysql-database) list)
284 (let* ((res-ptr (mysql-result-set-res-ptr result-set))
285 (row (mysql-fetch-row res-ptr))
286 (types (mysql-result-set-types result-set)))
287 (declare (type mysql-mysql-res-ptr-def res-ptr)
288 (type mysql-row-def row))
289 (unless (uffi:null-pointer-p row)
290 (loop for i from 0 below (mysql-result-set-num-fields result-set)
295 (uffi:deref-array row 'mysql-row i)