1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: mysql-sql.lisp
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
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 (eval-when (:compile-toplevel)
22 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))))
24 ;;;; Modified by Kevin Rosenberg, Feb 20002
25 ;;;; -- Added support for Allegro CL and Lispworks using UFFI layer
26 ;;;; -- Changed database-connect to use mysql-real-connect. This way,
27 ;;;; can avoid using double (unwind-protect)
28 ;;;; -- Changed database-connect to have MySQL library allocate space
29 ;;;; for MYSQL structure. This will make the code more robust in
30 ;;;; the event that MySQL library changes the size of the mysql-mysql
34 ;;;; Added field types
36 (defpackage #:clsql-mysql
37 (:use #:common-lisp #:clsql-base-sys #:mysql #:clsql-uffi)
38 (:export #:mysql-database)
39 (:documentation "This is the CLSQL interface to MySQL."))
41 (in-package #:clsql-mysql)
43 ;;; Field conversion functions
45 (defun make-type-list-for-auto (num-fields res-ptr)
46 (declare (fixnum num-fields))
48 #+ignore (field-vec (mysql-fetch-fields res-ptr)))
49 (dotimes (i num-fields)
51 (let* ( (field (mysql-fetch-field-direct res-ptr i))
52 #+ignore (field (uffi:deref-array field-vec '(:array mysql-field) i))
53 (type (uffi:get-slot-value field 'mysql-field 'type)))
56 ((#.mysql-field-types#tiny
57 #.mysql-field-types#short
58 #.mysql-field-types#int24
59 #.mysql-field-types#long)
61 (#.mysql-field-types#longlong
63 ((#.mysql-field-types#double
64 #.mysql-field-types#float
65 #.mysql-field-types#decimal)
70 (nreverse new-types)))
72 (defun canonicalize-types (types num-fields res-ptr)
74 (let ((auto-list (make-type-list-for-auto num-fields res-ptr)))
77 (canonicalize-type-list types auto-list))
83 (defmethod database-initialize-database-type ((database-type (eql :mysql)))
86 (uffi:def-type mysql-mysql-ptr-def (* mysql-mysql))
87 (uffi:def-type mysql-row-def mysql-row)
88 (uffi:def-type mysql-mysql-res-ptr-def (* mysql-mysql-res))
90 (defclass mysql-database (database)
91 ((mysql-ptr :accessor database-mysql-ptr :initarg :mysql-ptr
92 :type mysql-mysql-ptr-def)))
94 (defmethod database-type ((database mysql-database))
97 (defmethod database-name-from-spec (connection-spec (database-type (eql :mysql)))
98 (check-connection-spec connection-spec database-type (host db user password))
99 (destructuring-bind (host db user password) connection-spec
100 (declare (ignore password))
101 (concatenate 'string host "/" db "/" user)))
103 (defmethod database-connect (connection-spec (database-type (eql :mysql)))
104 (check-connection-spec connection-spec database-type (host db user password))
105 (destructuring-bind (host db user password) connection-spec
106 (let ((mysql-ptr (mysql-init (uffi:make-null-pointer 'mysql-mysql)))
108 (if (uffi:null-pointer-p mysql-ptr)
109 (error 'clsql-connect-error
110 :database-type database-type
111 :connection-spec connection-spec
112 :errno (mysql-errno mysql-ptr)
113 :error (mysql-error-string mysql-ptr))
114 (uffi:with-cstrings ((host-native host)
116 (password-native password)
118 (socket-native socket))
119 (let ((error-occurred nil))
121 (if (uffi:null-pointer-p
123 mysql-ptr host-native user-native password-native
124 db-native 0 socket-native 0))
126 (setq error-occurred t)
127 (error 'clsql-connect-error
128 :database-type database-type
129 :connection-spec connection-spec
130 :errno (mysql-errno mysql-ptr)
131 :error (mysql-error-string mysql-ptr)))
132 (make-instance 'mysql-database
133 :name (database-name-from-spec connection-spec
135 :connection-spec connection-spec
136 :mysql-ptr mysql-ptr))
137 (when error-occurred (mysql-close mysql-ptr)))))))))
140 (defmethod database-disconnect ((database mysql-database))
141 (mysql-close (database-mysql-ptr database))
142 (setf (database-mysql-ptr database) nil)
146 (defmethod database-query (query-expression (database mysql-database)
148 (declare (optimize (speed 3) (safety 0) (debug 0) (space 0)))
149 (let ((mysql-ptr (database-mysql-ptr database)))
150 (uffi:with-cstring (query-native query-expression)
151 (if (zerop (mysql-real-query mysql-ptr query-native
152 (length query-expression)))
153 (let ((res-ptr (mysql-use-result mysql-ptr)))
156 (let ((num-fields (mysql-num-fields res-ptr)))
157 (declare (fixnum num-fields))
158 (setq types (canonicalize-types
161 (loop for row = (mysql-fetch-row res-ptr)
162 for lengths = (mysql-fetch-lengths res-ptr)
163 until (uffi:null-pointer-p row)
165 (do* ((rlist (make-list num-fields))
167 (pos rlist (cdr pos)))
168 ((= i num-fields) rlist)
172 (uffi:deref-array row '(:array
176 (uffi:deref-array lengths '(:array :unsigned-long)
178 (mysql-free-result res-ptr))
179 (error 'clsql-sql-error
181 :expression query-expression
182 :errno (mysql-errno mysql-ptr)
183 :error (mysql-error-string mysql-ptr))))
184 (error 'clsql-sql-error
186 :expression query-expression
187 :errno (mysql-errno mysql-ptr)
188 :error (mysql-error-string mysql-ptr))))))
191 (defmethod database-query (query-expression (database mysql-database)
193 (declare (optimize (speed 3) (safety 0) (debug 0) (space 0)))
194 (let ((mysql-ptr (database-mysql-ptr database)))
195 (uffi:with-cstring (query-native query-expression)
196 (if (zerop (mysql-query mysql-ptr query-native))
197 (let ((res-ptr (mysql-use-result mysql-ptr)))
200 (let ((num-fields (mysql-num-fields res-ptr)))
201 (declare (fixnum num-fields))
202 (setq types (canonicalize-types
205 (loop for row = (mysql-fetch-row res-ptr)
206 until (uffi:null-pointer-p row)
208 (loop for i fixnum from 0 below num-fields
211 (uffi:deref-array row '(:array
215 (mysql-free-result res-ptr))
216 (error 'clsql-sql-error
218 :expression query-expression
219 :errno (mysql-errno mysql-ptr)
220 :error (mysql-error-string mysql-ptr))))
221 (error 'clsql-sql-error
223 :expression query-expression
224 :errno (mysql-errno mysql-ptr)
225 :error (mysql-error-string mysql-ptr))))))
227 (defmethod database-execute-command (sql-expression (database mysql-database))
228 (uffi:with-cstring (sql-native sql-expression)
229 (let ((mysql-ptr (database-mysql-ptr database)))
230 (declare (type mysql-mysql-ptr-def mysql-ptr))
231 (if (zerop (mysql-real-query mysql-ptr sql-native
232 (length sql-expression)))
234 (error 'clsql-sql-error
236 :expression sql-expression
237 :errno (mysql-errno mysql-ptr)
238 :error (mysql-error-string mysql-ptr))))))
241 (defstruct mysql-result-set
242 (res-ptr (uffi:make-null-pointer 'mysql-mysql-res) :type mysql-mysql-res-ptr-def)
243 (types nil :type list)
244 (num-fields 0 :type fixnum)
245 (full-set nil :type boolean))
248 (defmethod database-query-result-set (query-expression
249 (database mysql-database)
251 (uffi:with-cstring (query-native query-expression)
252 (let ((mysql-ptr (database-mysql-ptr database)))
253 (declare (type mysql-mysql-ptr-def mysql-ptr))
254 (if (zerop (mysql-real-query mysql-ptr query-native
255 (length query-expression)))
256 (let ((res-ptr (if full-set
257 (mysql-store-result mysql-ptr)
258 (mysql-use-result mysql-ptr))))
259 (declare (type mysql-mysql-res-ptr-def res-ptr))
260 (if (not (uffi:null-pointer-p res-ptr))
261 (let* ((num-fields (mysql-num-fields res-ptr))
262 (result-set (make-mysql-result-set
264 :num-fields num-fields
273 (mysql-num-rows res-ptr))
276 (error 'clsql-sql-error
278 :expression query-expression
279 :errno (mysql-errno mysql-ptr)
280 :error (mysql-error-string mysql-ptr))))
281 (error 'clsql-sql-error
283 :expression query-expression
284 :errno (mysql-errno mysql-ptr)
285 :error (mysql-error-string mysql-ptr))))))
287 (defmethod database-dump-result-set (result-set (database mysql-database))
288 (mysql-free-result (mysql-result-set-res-ptr result-set))
292 (defmethod database-store-next-row (result-set (database mysql-database) list)
293 (let* ((res-ptr (mysql-result-set-res-ptr result-set))
294 (row (mysql-fetch-row res-ptr))
295 (lengths (mysql-fetch-lengths res-ptr))
296 (types (mysql-result-set-types result-set)))
297 (declare (type mysql-mysql-res-ptr-def res-ptr)
298 (type mysql-row-def row))
299 (unless (uffi:null-pointer-p row)
300 (loop for i from 0 below (mysql-result-set-num-fields result-set)
305 (uffi:deref-array row '(:array (* :unsigned-char)) i)
308 (uffi:deref-array lengths :unsigned-long i))))
312 (when (clsql-base-sys:database-type-library-loaded :mysql)
313 (clsql-base-sys:initialize-database-type :database-type :mysql))