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))))))
174 (defmethod database-query (query-expression (database mysql-database)
176 (declare (optimize (speed 3) (safety 0) (debug 0) (space 0)))
177 (let ((mysql-ptr (database-mysql-ptr database)))
178 (uffi:with-cstring (query-native query-expression)
179 (if (zerop (mysql-query mysql-ptr query-native))
180 (let ((res-ptr (mysql-use-result mysql-ptr)))
183 (let ((num-fields (mysql-num-fields res-ptr)))
184 (declare (fixnum num-fields))
185 (setq result-types (canonicalize-types
186 result-types num-fields
188 (loop for row = (mysql-fetch-row res-ptr)
189 until (uffi:null-pointer-p row)
191 (loop for i fixnum from 0 below num-fields
194 (uffi:deref-array row '(:array
198 (mysql-free-result res-ptr))
199 (error 'clsql-sql-error
201 :expression query-expression
202 :errno (mysql-errno mysql-ptr)
203 :error (mysql-error-string mysql-ptr))))
204 (error 'clsql-sql-error
206 :expression query-expression
207 :errno (mysql-errno mysql-ptr)
208 :error (mysql-error-string mysql-ptr))))))
210 (defmethod database-execute-command (sql-expression (database mysql-database))
211 (uffi:with-cstring (sql-native sql-expression)
212 (let ((mysql-ptr (database-mysql-ptr database)))
213 (declare (type mysql-mysql-ptr-def mysql-ptr))
214 (if (zerop (mysql-real-query mysql-ptr sql-native
215 (length sql-expression)))
217 (error 'clsql-sql-error
219 :expression sql-expression
220 :errno (mysql-errno mysql-ptr)
221 :error (mysql-error-string mysql-ptr))))))
224 (defstruct mysql-result-set
225 (res-ptr (uffi:make-null-pointer 'mysql-mysql-res) :type mysql-mysql-res-ptr-def)
226 (types nil :type list)
227 (num-fields 0 :type fixnum)
228 (full-set nil :type boolean))
231 (defmethod database-query-result-set ((query-expression string)
232 (database mysql-database)
233 &key full-set result-types)
234 (uffi:with-cstring (query-native query-expression)
235 (let ((mysql-ptr (database-mysql-ptr database)))
236 (declare (type mysql-mysql-ptr-def mysql-ptr))
237 (if (zerop (mysql-real-query mysql-ptr query-native
238 (length query-expression)))
239 (let ((res-ptr (if full-set
240 (mysql-store-result mysql-ptr)
241 (mysql-use-result mysql-ptr))))
242 (declare (type mysql-mysql-res-ptr-def res-ptr))
243 (if (not (uffi:null-pointer-p res-ptr))
244 (let* ((num-fields (mysql-num-fields res-ptr))
245 (result-set (make-mysql-result-set
247 :num-fields num-fields
251 result-types num-fields
256 (mysql-num-rows res-ptr))
259 (error 'clsql-sql-error
261 :expression query-expression
262 :errno (mysql-errno mysql-ptr)
263 :error (mysql-error-string mysql-ptr))))
264 (error 'clsql-sql-error
266 :expression query-expression
267 :errno (mysql-errno mysql-ptr)
268 :error (mysql-error-string mysql-ptr))))))
270 (defmethod database-dump-result-set (result-set (database mysql-database))
271 (mysql-free-result (mysql-result-set-res-ptr result-set))
275 (defmethod database-store-next-row (result-set (database mysql-database) list)
276 (let* ((res-ptr (mysql-result-set-res-ptr result-set))
277 (row (mysql-fetch-row res-ptr))
278 (lengths (mysql-fetch-lengths res-ptr))
279 (types (mysql-result-set-types result-set)))
280 (declare (type mysql-mysql-res-ptr-def res-ptr)
281 (type mysql-row-def row))
282 (unless (uffi:null-pointer-p row)
283 (loop for i from 0 below (mysql-result-set-num-fields result-set)
288 (uffi:deref-array row '(:array (* :unsigned-char)) i)
291 (uffi:deref-array lengths '(:array :unsigned-long) i))))
295 ;; Table and attribute introspection
297 (defmethod database-list-tables ((database mysql-database) &key (owner nil))
298 (declare (ignore owner))
299 (remove-if #'(lambda (s)
300 (and (>= (length s) 11)
301 (string= (subseq s 0 11) "_clsql_seq_")))
302 (mapcar #'car (database-query "SHOW TABLES" database nil))))
304 ;; MySQL 4.1 does not support views
305 (defmethod database-list-views ((database mysql-database)
307 (declare (ignore owner))
310 (defmethod database-list-indexes ((database mysql-database)
313 (dolist (table (database-list-tables database :owner owner) result)
314 (mapc #'(lambda (index) (push (nth 2 index) result))
316 (format nil "SHOW INDEX FROM ~A" (string-upcase table))
319 (defmethod database-list-attributes ((table string) (database mysql-database)
321 (declare (ignore owner))
324 (format nil "SHOW COLUMNS FROM ~A" table)
327 (defmethod database-attribute-type (attribute (table string)
328 (database mysql-database)
330 (declare (ignore owner))
335 "SHOW COLUMNS FROM ~A LIKE '~A'" table attribute)
337 (let* ((str (car result))
338 (end-str (position #\( str))
339 (substr (subseq str 0 end-str)))
341 (intern (string-upcase substr) :keyword) nil))))
343 ;;; Sequence functions
345 (defun %sequence-name-to-table (sequence-name)
346 (concatenate 'string "_clsql_seq_" (sql-escape sequence-name)))
348 (defun %table-name-to-sequence-name (table-name)
349 (and (>= (length table-name) 11)
350 (string= (subseq table-name 0 11) "_clsql_seq_")
351 (subseq table-name 11)))
353 (defmethod database-create-sequence (sequence-name
354 (database mysql-database))
355 (let ((table-name (%sequence-name-to-table sequence-name)))
356 (database-execute-command
357 (concatenate 'string "CREATE TABLE " table-name
358 " (id int NOT NULL PRIMARY KEY AUTO_INCREMENT)")
360 (database-execute-command
361 (concatenate 'string "INSERT INTO " table-name
365 (defmethod database-drop-sequence (sequence-name
366 (database mysql-database))
367 (database-execute-command
368 (concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name))
371 (defmethod database-list-sequences ((database mysql-database)
373 (declare (ignore owner))
374 (mapcar #'(lambda (s) (%table-name-to-sequence-name (car s)))
375 (database-query "SHOW TABLES LIKE '%clsql_seq%'"
378 (defmethod database-set-sequence-position (sequence-name
380 (database mysql-database))
381 (database-execute-command
382 (format nil "UPDATE ~A SET id=~A" (%sequence-name-to-table sequence-name)
385 (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database)))
387 (defmethod database-sequence-next (sequence-name (database mysql-database))
388 (database-execute-command
389 (concatenate 'string "UPDATE " (%sequence-name-to-table sequence-name)
390 " SET id=LAST_INSERT_ID(id+1)")
392 (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database)))
394 (defmethod database-sequence-last (sequence-name (database mysql-database))
395 (declare (ignore sequence-name)))
399 (defmethod database-create (connection-spec (type (eql :mysql)))
400 (destructuring-bind (host name user password) connection-spec
401 (multiple-value-bind (output status)
402 (clsql-base-sys:command-output "mysqladmin create -u~A -p~A -h~A ~A"
404 (if host host "localhost")
406 (if (or (not (eql 0 status))
407 (and (search "failed" output) (search "error" output)))
408 (error 'clsql-access-error
409 :connection-spec connection-spec
412 (format nil "database-create failed: ~A" output))
415 (defmethod database-destroy (connection-spec (type (eql :mysql)))
416 (destructuring-bind (host name user password) connection-spec
417 (multiple-value-bind (output status)
418 (clsql-base-sys:command-output "mysqladmin drop -f -u~A -p~A -h~A ~A"
420 (if host host "localhost")
422 (if (or (not (eql 0 status))
423 (and (search "failed" output) (search "error" output)))
424 (error 'clsql-access-error
425 :connection-spec connection-spec
428 (format nil "database-destroy failed: ~A" output))
431 (defmethod database-probe (connection-spec (type (eql :mysql)))
432 (destructuring-bind (host name user password) connection-spec
433 (let ((database (database-connect (list host "mysql" user password) type)))
436 (find name (database-query "select db from db"
438 :key #'car :test #'string-equal)
440 (database-disconnect database)))))
443 (when (clsql-base-sys:database-type-library-loaded :mysql)
444 (clsql-base-sys:initialize-database-type :database-type :mysql))