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))
81 (concatenate 'string host "/" db "/" user)))
83 (defmethod database-connect (connection-spec (database-type (eql :mysql)))
84 (check-connection-spec connection-spec database-type (host db user password))
85 (destructuring-bind (host db user password) connection-spec
86 (let ((mysql-ptr (mysql-init (uffi:make-null-pointer 'mysql-mysql)))
88 (if (uffi:null-pointer-p mysql-ptr)
89 (error 'clsql-connect-error
90 :database-type database-type
91 :connection-spec connection-spec
92 :errno (mysql-errno mysql-ptr)
93 :error (mysql-error-string mysql-ptr))
94 (uffi:with-cstrings ((host-native host)
96 (password-native password)
98 (socket-native socket))
99 (let ((error-occurred nil))
101 (if (uffi:null-pointer-p
103 mysql-ptr host-native user-native password-native
104 db-native 0 socket-native 0))
106 (setq error-occurred t)
107 (error 'clsql-connect-error
108 :database-type database-type
109 :connection-spec connection-spec
110 :errno (mysql-errno mysql-ptr)
111 :error (mysql-error-string mysql-ptr)))
112 (make-instance 'mysql-database
113 :name (database-name-from-spec connection-spec
115 :connection-spec connection-spec
116 :mysql-ptr mysql-ptr))
117 (when error-occurred (mysql-close mysql-ptr)))))))))
120 (defmethod database-disconnect ((database mysql-database))
121 (mysql-close (database-mysql-ptr database))
122 (setf (database-mysql-ptr database) nil)
126 (defmethod database-query (query-expression (database mysql-database)
128 (declare (optimize (speed 3) (safety 0) (debug 0) (space 0)))
129 (let ((mysql-ptr (database-mysql-ptr database)))
130 (uffi:with-cstring (query-native query-expression)
131 (if (zerop (mysql-real-query mysql-ptr query-native
132 (length query-expression)))
133 (let ((res-ptr (mysql-use-result mysql-ptr)))
136 (let ((num-fields (mysql-num-fields res-ptr)))
137 (declare (fixnum num-fields))
138 (setq result-types (canonicalize-types
139 result-types num-fields
141 (loop for row = (mysql-fetch-row res-ptr)
142 for lengths = (mysql-fetch-lengths res-ptr)
143 until (uffi:null-pointer-p row)
145 (do* ((rlist (make-list num-fields))
147 (pos rlist (cdr pos)))
148 ((= i num-fields) rlist)
152 (uffi:deref-array row '(:array
156 (uffi:deref-array lengths '(:array :unsigned-long)
158 (mysql-free-result res-ptr))
159 (error 'clsql-sql-error
161 :expression query-expression
162 :errno (mysql-errno mysql-ptr)
163 :error (mysql-error-string mysql-ptr))))
164 (error 'clsql-sql-error
166 :expression query-expression
167 :errno (mysql-errno mysql-ptr)
168 :error (mysql-error-string mysql-ptr))))))
171 (defmethod database-query (query-expression (database mysql-database)
173 (declare (optimize (speed 3) (safety 0) (debug 0) (space 0)))
174 (let ((mysql-ptr (database-mysql-ptr database)))
175 (uffi:with-cstring (query-native query-expression)
176 (if (zerop (mysql-query mysql-ptr query-native))
177 (let ((res-ptr (mysql-use-result mysql-ptr)))
180 (let ((num-fields (mysql-num-fields res-ptr)))
181 (declare (fixnum num-fields))
182 (setq result-types (canonicalize-types
183 result-types num-fields
185 (loop for row = (mysql-fetch-row res-ptr)
186 until (uffi:null-pointer-p row)
188 (loop for i fixnum from 0 below num-fields
191 (uffi:deref-array row '(:array
195 (mysql-free-result res-ptr))
196 (error 'clsql-sql-error
198 :expression query-expression
199 :errno (mysql-errno mysql-ptr)
200 :error (mysql-error-string mysql-ptr))))
201 (error 'clsql-sql-error
203 :expression query-expression
204 :errno (mysql-errno mysql-ptr)
205 :error (mysql-error-string mysql-ptr))))))
207 (defmethod database-execute-command (sql-expression (database mysql-database))
208 (uffi:with-cstring (sql-native sql-expression)
209 (let ((mysql-ptr (database-mysql-ptr database)))
210 (declare (type mysql-mysql-ptr-def mysql-ptr))
211 (if (zerop (mysql-real-query mysql-ptr sql-native
212 (length sql-expression)))
214 (error 'clsql-sql-error
216 :expression sql-expression
217 :errno (mysql-errno mysql-ptr)
218 :error (mysql-error-string mysql-ptr))))))
221 (defstruct mysql-result-set
222 (res-ptr (uffi:make-null-pointer 'mysql-mysql-res) :type mysql-mysql-res-ptr-def)
223 (types nil :type list)
224 (num-fields 0 :type fixnum)
225 (full-set nil :type boolean))
228 (defmethod database-query-result-set ((query-expression string)
229 (database mysql-database)
230 &key full-set result-types)
231 (uffi:with-cstring (query-native query-expression)
232 (let ((mysql-ptr (database-mysql-ptr database)))
233 (declare (type mysql-mysql-ptr-def mysql-ptr))
234 (if (zerop (mysql-real-query mysql-ptr query-native
235 (length query-expression)))
236 (let ((res-ptr (if full-set
237 (mysql-store-result mysql-ptr)
238 (mysql-use-result mysql-ptr))))
239 (declare (type mysql-mysql-res-ptr-def res-ptr))
240 (if (not (uffi:null-pointer-p res-ptr))
241 (let* ((num-fields (mysql-num-fields res-ptr))
242 (result-set (make-mysql-result-set
244 :num-fields num-fields
248 result-types num-fields
253 (mysql-num-rows res-ptr))
256 (error 'clsql-sql-error
258 :expression query-expression
259 :errno (mysql-errno mysql-ptr)
260 :error (mysql-error-string mysql-ptr))))
261 (error 'clsql-sql-error
263 :expression query-expression
264 :errno (mysql-errno mysql-ptr)
265 :error (mysql-error-string mysql-ptr))))))
267 (defmethod database-dump-result-set (result-set (database mysql-database))
268 (mysql-free-result (mysql-result-set-res-ptr result-set))
272 (defmethod database-store-next-row (result-set (database mysql-database) list)
273 (let* ((res-ptr (mysql-result-set-res-ptr result-set))
274 (row (mysql-fetch-row res-ptr))
275 (lengths (mysql-fetch-lengths res-ptr))
276 (types (mysql-result-set-types result-set)))
277 (declare (type mysql-mysql-res-ptr-def res-ptr)
278 (type mysql-row-def row))
279 (unless (uffi:null-pointer-p row)
280 (loop for i from 0 below (mysql-result-set-num-fields result-set)
285 (uffi:deref-array row '(:array (* :unsigned-char)) i)
288 (uffi:deref-array lengths '(:array :unsigned-long) i))))
292 ;; Table and attribute introspection
294 (defmethod database-list-tables ((database mysql-database) &key (owner nil))
295 (declare (ignore owner))
296 (remove-if #'(lambda (s)
297 (and (>= (length s) 11)
298 (string= (subseq s 0 11) "_clsql_seq_")))
299 (mapcar #'car (database-query "SHOW TABLES" database nil))))
301 ;; MySQL 4.1 does not support views
302 (defmethod database-list-views ((database mysql-database)
304 (declare (ignore owner))
307 (defmethod database-list-indexes ((database mysql-database)
310 (dolist (table (database-list-tables database :owner owner) result)
311 (mapc #'(lambda (index) (push (nth 2 index) result))
313 (format nil "SHOW INDEX FROM ~A" (string-upcase table))
316 (defmethod database-list-attributes ((table string) (database mysql-database)
318 (declare (ignore owner))
321 (format nil "SHOW COLUMNS FROM ~A" table)
324 (defmethod database-attribute-type (attribute (table string)
325 (database mysql-database)
327 (declare (ignore owner))
332 "SHOW COLUMNS FROM ~A LIKE '~A'" table attribute)
334 (let* ((str (car result))
335 (end-str (position #\( str))
336 (substr (subseq str 0 end-str)))
338 (intern (string-upcase substr) :keyword) nil))))
340 ;;; Sequence functions
342 (defun %sequence-name-to-table (sequence-name)
343 (concatenate 'string "_clsql_seq_" (sql-escape sequence-name)))
345 (defun %table-name-to-sequence-name (table-name)
346 (and (>= (length table-name) 11)
347 (string= (subseq table-name 0 11) "_clsql_seq_")
348 (subseq table-name 11)))
350 (defmethod database-create-sequence (sequence-name
351 (database mysql-database))
352 (let ((table-name (%sequence-name-to-table sequence-name)))
353 (database-execute-command
354 (concatenate 'string "CREATE TABLE " table-name
355 " (id int NOT NULL PRIMARY KEY AUTO_INCREMENT)")
357 (database-execute-command
358 (concatenate 'string "INSERT INTO " table-name
362 (defmethod database-drop-sequence (sequence-name
363 (database mysql-database))
364 (database-execute-command
365 (concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name))
368 (defmethod database-list-sequences ((database mysql-database)
370 (declare (ignore owner))
371 (mapcar #'(lambda (s) (%table-name-to-sequence-name (car s)))
372 (database-query "SHOW TABLES LIKE '%clsql_seq%'"
375 (defmethod database-set-sequence-position (sequence-name
377 (database mysql-database))
378 (database-execute-command
379 (format nil "UPDATE ~A SET id=~A" (%sequence-name-to-table sequence-name)
382 (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database)))
384 (defmethod database-sequence-next (sequence-name (database mysql-database))
385 (database-execute-command
386 (concatenate 'string "UPDATE " (%sequence-name-to-table sequence-name)
387 " SET id=LAST_INSERT_ID(id+1)")
389 (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database)))
391 (defmethod database-sequence-last (sequence-name (database mysql-database))
392 (declare (ignore sequence-name)))
394 ;; Functions depending upon high-level CommonSQL classes/functions
396 (defmethod database-output-sql ((expr clsql-sys::sql-typecast-exp)
397 (database mysql-database))
398 (with-slots (clsql-sys::modifier clsql-sys::components)
400 (if clsql-sys::modifier
402 (clsql-sys::output-sql clsql-sys::components database)
403 (write-char #\: sql-sys::*sql-stream*)
404 (write-char #\: sql-sys::*sql-stream*)
405 (write-string (symbol-name clsql-sys::modifier)
406 clsql-sys::*sql-stream*)))))
408 (defmethod database-output-sql-as-type ((type (eql 'integer)) val
409 (database mysql-database))
410 ;; typecast it so it uses the indexes
412 (make-instance 'clsql-sys::sql-typecast-exp
417 (when (clsql-base-sys:database-type-library-loaded :mysql)
418 (clsql-base-sys:initialize-database-type :database-type :mysql))