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 :database-type :mysql
118 :connection-spec connection-spec
119 :mysql-ptr mysql-ptr))
120 (when error-occurred (mysql-close mysql-ptr)))))))))
123 (defmethod database-disconnect ((database mysql-database))
124 (mysql-close (database-mysql-ptr database))
125 (setf (database-mysql-ptr database) nil)
129 (defmethod database-query (query-expression (database mysql-database)
131 (declare (optimize (speed 3) (safety 0) (debug 0) (space 0)))
132 (let ((mysql-ptr (database-mysql-ptr database)))
133 (uffi:with-cstring (query-native query-expression)
134 (if (zerop (mysql-real-query mysql-ptr query-native
135 (length query-expression)))
136 (let ((res-ptr (mysql-use-result mysql-ptr)))
139 (let ((num-fields (mysql-num-fields res-ptr)))
140 (declare (fixnum num-fields))
141 (setq result-types (canonicalize-types
142 result-types num-fields
144 (loop for row = (mysql-fetch-row res-ptr)
145 for lengths = (mysql-fetch-lengths res-ptr)
146 until (uffi:null-pointer-p row)
148 (do* ((rlist (make-list num-fields))
150 (pos rlist (cdr pos)))
151 ((= i num-fields) rlist)
155 (uffi:deref-array row '(:array
159 (uffi:deref-array lengths '(:array :unsigned-long)
161 (mysql-free-result res-ptr))
162 (error 'clsql-sql-error
164 :expression query-expression
165 :errno (mysql-errno mysql-ptr)
166 :error (mysql-error-string mysql-ptr))))
167 (error 'clsql-sql-error
169 :expression query-expression
170 :errno (mysql-errno mysql-ptr)
171 :error (mysql-error-string mysql-ptr))))))
173 (defmethod database-execute-command (sql-expression (database mysql-database))
174 (uffi:with-cstring (sql-native sql-expression)
175 (let ((mysql-ptr (database-mysql-ptr database)))
176 (declare (type mysql-mysql-ptr-def mysql-ptr))
177 (if (zerop (mysql-real-query mysql-ptr sql-native
178 (length sql-expression)))
180 (error 'clsql-sql-error
182 :expression sql-expression
183 :errno (mysql-errno mysql-ptr)
184 :error (mysql-error-string mysql-ptr))))))
187 (defstruct mysql-result-set
188 (res-ptr (uffi:make-null-pointer 'mysql-mysql-res) :type mysql-mysql-res-ptr-def)
189 (types nil :type list)
190 (num-fields 0 :type fixnum)
191 (full-set nil :type boolean))
194 (defmethod database-query-result-set ((query-expression string)
195 (database mysql-database)
196 &key full-set result-types)
197 (uffi:with-cstring (query-native query-expression)
198 (let ((mysql-ptr (database-mysql-ptr database)))
199 (declare (type mysql-mysql-ptr-def mysql-ptr))
200 (if (zerop (mysql-real-query mysql-ptr query-native
201 (length query-expression)))
202 (let ((res-ptr (if full-set
203 (mysql-store-result mysql-ptr)
204 (mysql-use-result mysql-ptr))))
205 (declare (type mysql-mysql-res-ptr-def res-ptr))
206 (if (not (uffi:null-pointer-p res-ptr))
207 (let* ((num-fields (mysql-num-fields res-ptr))
208 (result-set (make-mysql-result-set
210 :num-fields num-fields
214 result-types num-fields
219 (mysql-num-rows res-ptr))
222 (error 'clsql-sql-error
224 :expression query-expression
225 :errno (mysql-errno mysql-ptr)
226 :error (mysql-error-string mysql-ptr))))
227 (error 'clsql-sql-error
229 :expression query-expression
230 :errno (mysql-errno mysql-ptr)
231 :error (mysql-error-string mysql-ptr))))))
233 (defmethod database-dump-result-set (result-set (database mysql-database))
234 (mysql-free-result (mysql-result-set-res-ptr result-set))
238 (defmethod database-store-next-row (result-set (database mysql-database) list)
239 (let* ((res-ptr (mysql-result-set-res-ptr result-set))
240 (row (mysql-fetch-row res-ptr))
241 (lengths (mysql-fetch-lengths res-ptr))
242 (types (mysql-result-set-types result-set)))
243 (declare (type mysql-mysql-res-ptr-def res-ptr)
244 (type mysql-row-def row))
245 (unless (uffi:null-pointer-p row)
246 (loop for i from 0 below (mysql-result-set-num-fields result-set)
251 (uffi:deref-array row '(:array (* :unsigned-char)) i)
254 (uffi:deref-array lengths '(:array :unsigned-long) i))))
258 ;; Table and attribute introspection
260 (defmethod database-list-tables ((database mysql-database) &key (owner nil))
261 (declare (ignore owner))
262 (remove-if #'(lambda (s)
263 (and (>= (length s) 11)
264 (string= (subseq s 0 11) "_clsql_seq_")))
265 (mapcar #'car (database-query "SHOW TABLES" database nil))))
267 ;; MySQL 4.1 does not support views
268 (defmethod database-list-views ((database mysql-database)
270 (declare (ignore owner))
273 (defmethod database-list-indexes ((database mysql-database)
276 (dolist (table (database-list-tables database :owner owner) result)
277 (mapc #'(lambda (index) (push (nth 2 index) result))
279 (format nil "SHOW INDEX FROM ~A" (string-upcase table))
282 (defmethod database-list-attributes ((table string) (database mysql-database)
284 (declare (ignore owner))
287 (format nil "SHOW COLUMNS FROM ~A" table)
290 (defmethod database-attribute-type (attribute (table string)
291 (database mysql-database)
293 (declare (ignore owner))
298 "SHOW COLUMNS FROM ~A LIKE '~A'" table attribute)
300 (let* ((str (car result))
301 (end-str (position #\( str))
302 (substr (subseq str 0 end-str)))
304 (intern (string-upcase substr) :keyword) nil))))
306 ;;; Sequence functions
308 (defun %sequence-name-to-table (sequence-name)
309 (concatenate 'string "_clsql_seq_" (sql-escape sequence-name)))
311 (defun %table-name-to-sequence-name (table-name)
312 (and (>= (length table-name) 11)
313 (string= (subseq table-name 0 11) "_clsql_seq_")
314 (subseq table-name 11)))
316 (defmethod database-create-sequence (sequence-name
317 (database mysql-database))
318 (let ((table-name (%sequence-name-to-table sequence-name)))
319 (database-execute-command
320 (concatenate 'string "CREATE TABLE " table-name
321 " (id int NOT NULL PRIMARY KEY AUTO_INCREMENT)")
323 (database-execute-command
324 (concatenate 'string "INSERT INTO " table-name
328 (defmethod database-drop-sequence (sequence-name
329 (database mysql-database))
330 (database-execute-command
331 (concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name))
334 (defmethod database-list-sequences ((database mysql-database)
336 (declare (ignore owner))
337 (mapcar #'(lambda (s) (%table-name-to-sequence-name (car s)))
338 (database-query "SHOW TABLES LIKE '%clsql_seq%'"
341 (defmethod database-set-sequence-position (sequence-name
343 (database mysql-database))
344 (database-execute-command
345 (format nil "UPDATE ~A SET id=~A" (%sequence-name-to-table sequence-name)
348 (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database)))
350 (defmethod database-sequence-next (sequence-name (database mysql-database))
352 (database-execute-command
353 (concatenate 'string "UPDATE " (%sequence-name-to-table sequence-name)
354 " SET id=LAST_INSERT_ID(id+1)")
356 (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database))))
358 (defmethod database-sequence-last (sequence-name (database mysql-database))
359 (declare (ignore sequence-name)))
361 (defmethod database-create (connection-spec (type (eql :mysql)))
362 (destructuring-bind (host name user password) connection-spec
363 (multiple-value-bind (output status)
364 (clsql-base-sys:command-output "mysqladmin create -u~A -p~A -h~A ~A"
366 (if host host "localhost")
368 (if (or (not (eql 0 status))
369 (and (search "failed" output) (search "error" output)))
370 (error 'clsql-access-error
371 :connection-spec connection-spec
374 (format nil "database-create failed: ~A" output))
377 (defmethod database-destroy (connection-spec (type (eql :mysql)))
378 (destructuring-bind (host name user password) connection-spec
379 (multiple-value-bind (output status)
380 (clsql-base-sys:command-output "mysqladmin drop -f -u~A -p~A -h~A ~A"
382 (if host host "localhost")
384 (if (or (not (eql 0 status))
385 (and (search "failed" output) (search "error" output)))
386 (error 'clsql-access-error
387 :connection-spec connection-spec
390 (format nil "database-destroy failed: ~A" output))
393 (defmethod database-probe (connection-spec (type (eql :mysql)))
394 (when (find (second connection-spec) (database-list connection-spec type)
395 :key #'car :test #'string-equal)
398 (defmethod database-list (connection-spec (type (eql :mysql)))
399 (destructuring-bind (host name user password) connection-spec
400 (declare (ignore name))
401 (let ((database (database-connect (list host "mysql" user password) type)))
404 (setf (slot-value database 'clsql-base-sys::state) :open)
405 (mapcar #'car (database-query "show databases" database :auto)))
407 (database-disconnect database)
408 (setf (slot-value database 'clsql-base-sys::state) :closed))))))
411 (when (clsql-base-sys:database-type-library-loaded :mysql)
412 (clsql-base-sys:initialize-database-type :database-type :mysql))