1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: mysql-sql.cl
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
11 ;;;; $Id: mysql-sql.cl,v 1.1 2002/03/23 14:04:52 kevin Exp $
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 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
23 ;;;; Modified by Kevin Rosenberg, Feb 20002
24 ;;;; -- Added support for Allegro CL and Lispworks using UFFI layer
25 ;;;; -- Changed database-connect to use mysql-real-connect. This way,
26 ;;;; can avoid using double (unwind-protect)
27 ;;;; -- Changed database-connect to have MySQL library allocate space
28 ;;;; for MYSQL structure. This will make the code more robust in
29 ;;;; the event that MySQL library changes the size of the mysql-mysql
32 (defpackage :clsql-mysql
33 (:use :common-lisp :clsql-sys :mysql)
34 (:documentation "This is the CLSQL interface to MySQL."))
36 (in-package :clsql-mysql)
38 (defmethod database-initialize-database-type ((database-type (eql :mysql)))
41 (uffi:def-type mysql-mysql-ptr-def (* mysql-mysql))
42 (uffi:def-type mysql-row-def mysql-row)
43 (uffi:def-type mysql-mysql-res-ptr-def (* mysql-mysql-res))
45 (defclass mysql-database (database)
46 ((mysql-ptr :accessor database-mysql-ptr :initarg :mysql-ptr
47 :type mysql-mysql-ptr-def)))
49 (defmethod database-name-from-spec (connection-spec (database-type (eql :mysql)))
50 (check-connection-spec connection-spec database-type (host db user password))
51 (destructuring-bind (host db user password) connection-spec
52 (declare (ignore password))
53 (concatenate 'string host "/" db "/" user)))
55 (defmethod database-connect (connection-spec (database-type (eql :mysql)))
56 (check-connection-spec connection-spec database-type (host db user password))
57 (destructuring-bind (host db user password) connection-spec
58 (let ((mysql-ptr (mysql-init (uffi:make-null-pointer 'mysql-mysql)))
60 (if (uffi:null-pointer-p mysql-ptr)
61 (error 'clsql-connect-error
62 :database-type database-type
63 :connection-spec connection-spec
64 :errno (mysql-errno mysql-ptr)
65 :error (mysql-error-string mysql-ptr))
66 (uffi:with-cstring (host-native host)
67 (uffi:with-cstring (user-native user)
68 (uffi:with-cstring (password-native password)
69 (uffi:with-cstring (db-native db)
70 (uffi:with-cstring (socket-native socket)
71 (let ((error-occurred nil))
73 (if (uffi:null-pointer-p
75 mysql-ptr host-native user-native password-native
76 db-native 0 socket-native 0))
78 (setq error-occurred t)
79 (error 'clsql-connect-error
80 :database-type database-type
81 :connection-spec connection-spec
82 :errno (mysql-errno mysql-ptr)
83 :error (mysql-error-string mysql-ptr)))
84 (make-instance 'mysql-database
85 :name (database-name-from-spec connection-spec
87 :mysql-ptr mysql-ptr))
88 (when error-occurred (mysql-close mysql-ptr)))))))))))))
91 (defmethod database-disconnect ((database mysql-database))
92 (mysql-close (database-mysql-ptr database))
93 (setf (database-mysql-ptr database) nil)
97 (defstruct mysql-result-set
98 (res-ptr (uffi:make-null-pointer 'mysql-mysql-res)
99 :type mysql-mysql-res-ptr-def)
102 (defmethod database-dump-result-set (result-set (database mysql-database))
103 (mysql-free-result (mysql-result-set-res-ptr result-set))
107 (defmethod database-store-next-row (result-set (database mysql-database) list)
108 (let* ((res-ptr (mysql-result-set-res-ptr result-set))
109 (row (mysql-fetch-row res-ptr)))
110 (declare (type mysql-mysql-res-ptr-def res-ptr)
111 (type mysql-row-def row))
112 (unless (uffi:null-pointer-p row)
113 (loop for i from 0 below (mysql-num-fields res-ptr)
117 (uffi:convert-from-foreign-string (uffi:deref-array row 'mysql-row i))))
121 (defmethod database-execute-command (sql-expression (database mysql-database))
122 (uffi:with-cstring (sql-native sql-expression)
123 (let ((mysql-ptr (database-mysql-ptr database)))
124 (declare (type mysql-mysql-ptr-def mysql-ptr))
125 (if (zerop (mysql-query mysql-ptr sql-native))
127 (error 'clsql-sql-error
129 :expression sql-expression
130 :errno (mysql-errno mysql-ptr)
131 :error (mysql-error-string mysql-ptr))))))
135 (defmethod database-query (query-expression (database mysql-database))
136 (with-slots (mysql-ptr) database
137 (uffi:with-cstring (query-native query-expression)
138 (if (zerop (mysql-query mysql-ptr query-native))
139 (let ((res-ptr (mysql-use-result mysql-ptr)))
142 (loop for row = (mysql-fetch-row res-ptr)
143 until (uffi:null-pointer-p row)
145 (loop for i from 0 below (mysql-num-fields res-ptr)
147 (uffi:convert-from-cstring
148 (uffi:deref-array row 'mysql-row i))))
149 (mysql-free-result res-ptr))
150 (error 'clsql-sql-error
152 :expression query-expression
153 :errno (mysql-errno mysql-ptr)
154 :error (mysql-error-string mysql-ptr))))
155 (error 'clsql-sql-error
157 :expression query-expression
158 :errno (mysql-errno mysql-ptr)
159 :error (mysql-error-string mysql-ptr))))))
162 (defmethod database-query-result-set (query-expression
163 (database mysql-database)
165 (uffi:with-cstring (query-native query-expression)
166 (let ((mysql-ptr (database-mysql-ptr database)))
167 (declare (type mysql-mysql-ptr-def mysql-ptr))
168 (if (zerop (mysql-query mysql-ptr query-native))
169 (let ((res-ptr (if full-set
170 (mysql-store-result mysql-ptr)
171 (mysql-use-result mysql-ptr))))
172 (declare (type mysql-mysql-res-ptr-def res-ptr))
173 (if (not (uffi:null-pointer-p res-ptr))
175 (values (make-mysql-result-set :res-ptr res-ptr :full-set t)
176 (mysql-num-fields res-ptr)
177 (mysql-num-rows res-ptr))
178 (values (make-mysql-result-set :res-ptr res-ptr)
179 (mysql-num-fields res-ptr)))
180 (error 'clsql-sql-error
182 :expression query-expression
183 :errno (mysql-errno mysql-ptr)
184 :error (mysql-error-string mysql-ptr))))
185 (error 'clsql-sql-error
187 :expression query-expression
188 :errno (mysql-errno mysql-ptr)
189 :error (mysql-error-string mysql-ptr))))))