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 ;;;; Date Started: Feb 2002
11 ;;;; CLSQL users are granted the rights to distribute and use this software
12 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
13 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
14 ;;;; *************************************************************************
16 (defpackage #:clsql-mysql
17 (:use #:common-lisp #:clsql-base-sys #:mysql #:clsql-uffi)
18 (:export #:mysql-database)
19 (:documentation "This is the CLSQL interface to MySQL."))
21 (in-package #:clsql-mysql)
23 ;;; Field conversion functions
25 (defun make-type-list-for-auto (num-fields res-ptr)
26 (declare (fixnum num-fields))
28 #+ignore (field-vec (mysql-fetch-fields res-ptr)))
29 (dotimes (i num-fields)
31 (let* ( (field (mysql-fetch-field-direct res-ptr i))
32 #+ignore (field (uffi:deref-array field-vec '(:array mysql-field) i))
33 (type (uffi:get-slot-value field 'mysql-field 'type)))
36 ((#.mysql-field-types#tiny
37 #.mysql-field-types#short
38 #.mysql-field-types#int24
39 #.mysql-field-types#long)
41 (#.mysql-field-types#longlong
43 ((#.mysql-field-types#double
44 #.mysql-field-types#float
45 #.mysql-field-types#decimal)
50 (nreverse new-types)))
52 (defun canonicalize-types (types num-fields res-ptr)
54 (let ((auto-list (make-type-list-for-auto num-fields res-ptr)))
57 (canonicalize-type-list types auto-list))
63 (defmethod database-initialize-database-type ((database-type (eql :mysql)))
66 (uffi:def-type mysql-mysql-ptr-def (* mysql-mysql))
67 (uffi:def-type mysql-row-def mysql-row)
68 (uffi:def-type mysql-mysql-res-ptr-def (* mysql-mysql-res))
70 (defclass mysql-database (database)
71 ((mysql-ptr :accessor database-mysql-ptr :initarg :mysql-ptr
72 :type mysql-mysql-ptr-def)))
74 (defmethod database-type ((database mysql-database))
77 (defmethod database-name-from-spec (connection-spec (database-type (eql :mysql)))
78 (check-connection-spec connection-spec database-type (host db user password))
79 (destructuring-bind (host db user password) connection-spec
80 (declare (ignore password))
82 (if host host "localhost")
85 (defmethod database-connect (connection-spec (database-type (eql :mysql)))
86 (check-connection-spec connection-spec database-type (host db user password))
87 (destructuring-bind (host db user password) connection-spec
88 (let ((mysql-ptr (mysql-init (uffi:make-null-pointer 'mysql-mysql)))
90 (if (uffi:null-pointer-p mysql-ptr)
91 (error 'clsql-connect-error
92 :database-type database-type
93 :connection-spec connection-spec
94 :errno (mysql-errno mysql-ptr)
95 :error (mysql-error-string mysql-ptr))
96 (uffi:with-cstrings ((host-native host)
98 (password-native password)
100 (socket-native socket))
101 (let ((error-occurred nil))
103 (if (uffi:null-pointer-p
105 mysql-ptr host-native user-native password-native
106 db-native 0 socket-native 0))
108 (setq error-occurred t)
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 (make-instance 'mysql-database
115 :name (database-name-from-spec connection-spec
117 :connection-spec connection-spec
118 :mysql-ptr mysql-ptr))
119 (when error-occurred (mysql-close mysql-ptr)))))))))
122 (defmethod database-disconnect ((database mysql-database))
123 (mysql-close (database-mysql-ptr database))
124 (setf (database-mysql-ptr database) nil)
128 (defmethod database-query (query-expression (database mysql-database)
130 (declare (optimize (speed 3) (safety 0) (debug 0) (space 0)))
131 (let ((mysql-ptr (database-mysql-ptr database)))
132 (uffi:with-cstring (query-native query-expression)
133 (if (zerop (mysql-real-query mysql-ptr query-native
134 (length query-expression)))
135 (let ((res-ptr (mysql-use-result mysql-ptr)))
138 (let ((num-fields (mysql-num-fields res-ptr)))
139 (declare (fixnum num-fields))
140 (setq result-types (canonicalize-types
141 result-types num-fields
143 (loop for row = (mysql-fetch-row res-ptr)
144 for lengths = (mysql-fetch-lengths res-ptr)
145 until (uffi:null-pointer-p row)
147 (do* ((rlist (make-list num-fields))
149 (pos rlist (cdr pos)))
150 ((= i num-fields) rlist)
154 (uffi:deref-array row '(:array
158 (uffi:deref-array lengths '(:array :unsigned-long)
160 (mysql-free-result res-ptr))
161 (error 'clsql-sql-error
163 :expression query-expression
164 :errno (mysql-errno mysql-ptr)
165 :error (mysql-error-string mysql-ptr))))
166 (error 'clsql-sql-error
168 :expression query-expression
169 :errno (mysql-errno mysql-ptr)
170 :error (mysql-error-string mysql-ptr))))))
173 (defmethod database-query (query-expression (database mysql-database)
175 (declare (optimize (speed 3) (safety 0) (debug 0) (space 0)))
176 (let ((mysql-ptr (database-mysql-ptr database)))
177 (uffi:with-cstring (query-native query-expression)
178 (if (zerop (mysql-query mysql-ptr query-native))
179 (let ((res-ptr (mysql-use-result mysql-ptr)))
182 (let ((num-fields (mysql-num-fields res-ptr)))
183 (declare (fixnum num-fields))
184 (setq result-types (canonicalize-types
185 result-types num-fields
187 (loop for row = (mysql-fetch-row res-ptr)
188 until (uffi:null-pointer-p row)
190 (loop for i fixnum from 0 below num-fields
193 (uffi:deref-array row '(:array
197 (mysql-free-result res-ptr))
198 (error 'clsql-sql-error
200 :expression query-expression
201 :errno (mysql-errno mysql-ptr)
202 :error (mysql-error-string mysql-ptr))))
203 (error 'clsql-sql-error
205 :expression query-expression
206 :errno (mysql-errno mysql-ptr)
207 :error (mysql-error-string mysql-ptr))))))
209 (defmethod database-execute-command (sql-expression (database mysql-database))
210 (uffi:with-cstring (sql-native sql-expression)
211 (let ((mysql-ptr (database-mysql-ptr database)))
212 (declare (type mysql-mysql-ptr-def mysql-ptr))
213 (if (zerop (mysql-real-query mysql-ptr sql-native
214 (length sql-expression)))
216 (error 'clsql-sql-error
218 :expression sql-expression
219 :errno (mysql-errno mysql-ptr)
220 :error (mysql-error-string mysql-ptr))))))
223 (defstruct mysql-result-set
224 (res-ptr (uffi:make-null-pointer 'mysql-mysql-res) :type mysql-mysql-res-ptr-def)
225 (types nil :type list)
226 (num-fields 0 :type fixnum)
227 (full-set nil :type boolean))
230 (defmethod database-query-result-set ((query-expression string)
231 (database mysql-database)
232 &key full-set result-types)
233 (uffi:with-cstring (query-native query-expression)
234 (let ((mysql-ptr (database-mysql-ptr database)))
235 (declare (type mysql-mysql-ptr-def mysql-ptr))
236 (if (zerop (mysql-real-query mysql-ptr query-native
237 (length query-expression)))
238 (let ((res-ptr (if full-set
239 (mysql-store-result mysql-ptr)
240 (mysql-use-result mysql-ptr))))
241 (declare (type mysql-mysql-res-ptr-def res-ptr))
242 (if (not (uffi:null-pointer-p res-ptr))
243 (let* ((num-fields (mysql-num-fields res-ptr))
244 (result-set (make-mysql-result-set
246 :num-fields num-fields
250 result-types num-fields
255 (mysql-num-rows res-ptr))
258 (error 'clsql-sql-error
260 :expression query-expression
261 :errno (mysql-errno mysql-ptr)
262 :error (mysql-error-string mysql-ptr))))
263 (error 'clsql-sql-error
265 :expression query-expression
266 :errno (mysql-errno mysql-ptr)
267 :error (mysql-error-string mysql-ptr))))))
269 (defmethod database-dump-result-set (result-set (database mysql-database))
270 (mysql-free-result (mysql-result-set-res-ptr result-set))
274 (defmethod database-store-next-row (result-set (database mysql-database) list)
275 (let* ((res-ptr (mysql-result-set-res-ptr result-set))
276 (row (mysql-fetch-row res-ptr))
277 (lengths (mysql-fetch-lengths res-ptr))
278 (types (mysql-result-set-types result-set)))
279 (declare (type mysql-mysql-res-ptr-def res-ptr)
280 (type mysql-row-def row))
281 (unless (uffi:null-pointer-p row)
282 (loop for i from 0 below (mysql-result-set-num-fields result-set)
287 (uffi:deref-array row '(:array (* :unsigned-char)) i)
290 (uffi:deref-array lengths '(:array :unsigned-long) i))))
294 ;; Table and attribute introspection
296 (defmethod database-list-tables ((database mysql-database) &key (owner nil))
297 (declare (ignore owner))
298 (remove-if #'(lambda (s)
299 (and (>= (length s) 11)
300 (string= (subseq s 0 11) "_clsql_seq_")))
301 (mapcar #'car (database-query "SHOW TABLES" database nil))))
303 ;; MySQL 4.1 does not support views
304 (defmethod database-list-views ((database mysql-database)
306 (declare (ignore owner))
309 (defmethod database-list-indexes ((database mysql-database)
312 (dolist (table (database-list-tables database :owner owner) result)
313 (mapc #'(lambda (index) (push (nth 2 index) result))
315 (format nil "SHOW INDEX FROM ~A" (string-upcase table))
318 (defmethod database-list-attributes ((table string) (database mysql-database)
320 (declare (ignore owner))
323 (format nil "SHOW COLUMNS FROM ~A" table)
326 (defmethod database-attribute-type (attribute (table string)
327 (database mysql-database)
329 (declare (ignore owner))
334 "SHOW COLUMNS FROM ~A LIKE '~A'" table attribute)
336 (let* ((str (car result))
337 (end-str (position #\( str))
338 (substr (subseq str 0 end-str)))
340 (intern (string-upcase substr) :keyword) nil))))
342 ;;; Sequence functions
344 (defun %sequence-name-to-table (sequence-name)
345 (concatenate 'string "_clsql_seq_" (sql-escape sequence-name)))
347 (defun %table-name-to-sequence-name (table-name)
348 (and (>= (length table-name) 11)
349 (string= (subseq table-name 0 11) "_clsql_seq_")
350 (subseq table-name 11)))
352 (defmethod database-create-sequence (sequence-name
353 (database mysql-database))
354 (let ((table-name (%sequence-name-to-table sequence-name)))
355 (database-execute-command
356 (concatenate 'string "CREATE TABLE " table-name
357 " (id int NOT NULL PRIMARY KEY AUTO_INCREMENT)")
359 (database-execute-command
360 (concatenate 'string "INSERT INTO " table-name
364 (defmethod database-drop-sequence (sequence-name
365 (database mysql-database))
366 (database-execute-command
367 (concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name))
370 (defmethod database-list-sequences ((database mysql-database)
372 (declare (ignore owner))
373 (mapcar #'(lambda (s) (%table-name-to-sequence-name (car s)))
374 (database-query "SHOW TABLES LIKE '%clsql_seq%'"
377 (defmethod database-set-sequence-position (sequence-name
379 (database mysql-database))
380 (database-execute-command
381 (format nil "UPDATE ~A SET id=~A" (%sequence-name-to-table sequence-name)
384 (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database)))
386 (defmethod database-sequence-next (sequence-name (database mysql-database))
387 (database-execute-command
388 (concatenate 'string "UPDATE " (%sequence-name-to-table sequence-name)
389 " SET id=LAST_INSERT_ID(id+1)")
391 (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database)))
393 (defmethod database-sequence-last (sequence-name (database mysql-database))
394 (declare (ignore sequence-name)))
398 (defmethod database-create (connection-spec (type (eql :mysql)))
399 (destructuring-bind (host name user password) connection-spec
400 (multiple-value-bind (output status)
401 (clsql-base-sys:command-output "mysqladmin create -u~A -p~A -h~A ~A"
403 (if host host "localhost")
405 (if (or (not (eql 0 status))
406 (and (search "failed" output) (search "error" output)))
407 (error 'clsql-access-error
408 :connection-spec connection-spec
411 (format nil "database-create failed: ~A" output))
414 (defmethod database-destory (connection-spec (type (eql :mysql)))
415 (destructuring-bind (host name user password) connection-spec
416 (multiple-value-bind (output status)
417 (clsql-base-sys:command-output "mysqladmin drop -u~A -p~A -h~A ~A"
419 (if host host "localhost")
421 (if (or (not (eql 0 status))
422 (and (search "failed" output) (search "error" output)))
423 (error 'clsql-access-error
424 :connection-spec connection-spec
427 (format nil "database-destroy failed: ~A" output))
430 (defmethod database-probe (connection-spec (type (eql :mysql)))
431 (destructuring-bind (host name user password) connection-spec
432 (let ((database (database-connect (list host "mysql" user password) type)))
435 (find name (database-query "select db from db"
437 :key #'car :test #'string-equal)
439 (database-disconnect database)))))
442 (when (clsql-base-sys:database-type-library-loaded :mysql)
443 (clsql-base-sys:initialize-database-type :database-type :mysql))