;;;; Original code by Pierre R. Mai
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: mysql-sql.cl,v 1.5 2002/03/24 18:39:32 kevin Exp $
+;;;; $Id: mysql-sql.cl,v 1.22 2002/05/27 17:19:30 kevin Exp $
;;;;
;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
;;;; Added field types
(defpackage :clsql-mysql
- (:use :common-lisp :clsql-sys :mysql)
+ (:use :common-lisp :clsql-base-sys :mysql :clsql-uffi)
(:export #:mysql-database)
(:documentation "This is the CLSQL interface to MySQL."))
(in-package :clsql-mysql)
+;;; Field conversion functions
+
+(defun make-type-list-for-auto (num-fields res-ptr)
+ (let ((new-types '())
+ #+ignore (field-vec (mysql-fetch-fields res-ptr)))
+ (dotimes (i num-fields)
+ (declare (fixnum i))
+ (let* ( (field (mysql-fetch-field-direct res-ptr i))
+ #+ignore (field (uffi:deref-array field-vec 'mysql-field-vector i))
+ (type (uffi:get-slot-value field 'mysql-field 'type)))
+ (push
+ (case type
+ ((#.mysql-field-types#tiny
+ #.mysql-field-types#short
+ #.mysql-field-types#int24
+ #.mysql-field-types#long)
+ :int32)
+ (#.mysql-field-types#longlong
+ :int64)
+ ((#.mysql-field-types#double
+ #.mysql-field-types#float
+ #.mysql-field-types#decimal)
+ :double)
+ (otherwise
+ t))
+ new-types)))
+ (nreverse new-types)))
+
+(defun canonicalize-types (types num-fields res-ptr)
+ (if (null types)
+ nil
+ (let ((auto-list (make-type-list-for-auto num-fields res-ptr)))
+ (cond
+ ((listp types)
+ (canonicalize-type-list types auto-list))
+ ((eq types :auto)
+ auto-list)
+ (t
+ nil)))))
+
(defmethod database-initialize-database-type ((database-type (eql :mysql)))
t)
((mysql-ptr :accessor database-mysql-ptr :initarg :mysql-ptr
:type mysql-mysql-ptr-def)))
+(defmethod database-type ((database mysql-database))
+ :mysql)
+
(defmethod database-name-from-spec (connection-spec (database-type (eql :mysql)))
(check-connection-spec connection-spec database-type (host db user password))
(destructuring-bind (host db user password) connection-spec
(make-instance 'mysql-database
:name (database-name-from-spec connection-spec
database-type)
+ :connection-spec connection-spec
:mysql-ptr mysql-ptr))
(when error-occurred (mysql-close mysql-ptr)))))))))
t)
-(defstruct mysql-result-set
- (res-ptr (uffi:make-null-pointer 'mysql-mysql-res)
- :type mysql-mysql-res-ptr-def)
- (field-types nil :type cons)
- (full-set nil :type boolean))
-
-(defmethod database-dump-result-set (result-set (database mysql-database))
- (mysql-free-result (mysql-result-set-res-ptr result-set))
- t)
-
-
-(defmethod database-store-next-row (result-set (database mysql-database) list)
- (let* ((res-ptr (mysql-result-set-res-ptr result-set))
- (row (mysql-fetch-row res-ptr)))
- (declare (type mysql-mysql-res-ptr-def res-ptr)
- (type mysql-row-def row))
- (unless (uffi:null-pointer-p row)
- (loop for i from 0 below (mysql-num-fields res-ptr)
- for rest on list
- do
- (setf (car rest)
- (uffi:convert-from-foreign-string (uffi:deref-array row 'mysql-row i))))
- list)))
-
-
-(defmethod database-execute-command (sql-expression (database mysql-database))
- (uffi:with-cstring (sql-native sql-expression)
- (let ((mysql-ptr (database-mysql-ptr database)))
- (declare (type mysql-mysql-ptr-def mysql-ptr))
- (if (zerop (mysql-query mysql-ptr sql-native))
- t
- (error 'clsql-sql-error
- :database database
- :expression sql-expression
- :errno (mysql-errno mysql-ptr)
- :error (mysql-error-string mysql-ptr))))))
-
-
-
(defmethod database-query (query-expression (database mysql-database)
- field-types)
+ types)
(with-slots (mysql-ptr) database
(uffi:with-cstring (query-native query-expression)
(if (zerop (mysql-query mysql-ptr query-native))
(let ((res-ptr (mysql-use-result mysql-ptr)))
(if res-ptr
- (unwind-protect
- (loop for row = (mysql-fetch-row res-ptr)
- until (uffi:null-pointer-p row)
- collect
- (loop for i from 0 below (mysql-num-fields res-ptr)
- collect
- (uffi:convert-from-cstring
- (uffi:deref-array row 'mysql-row i))))
- (mysql-free-result res-ptr))
+ (let ((num-fields (mysql-num-fields res-ptr)))
+ (setq types (canonicalize-types
+ types num-fields
+ res-ptr))
+ (unwind-protect
+ (loop for row = (mysql-fetch-row res-ptr)
+ until (uffi:null-pointer-p row)
+ collect
+ (loop for i from 0 below num-fields
+ collect
+ (convert-raw-field
+ (uffi:deref-array row 'mysql-row i)
+ types i)))
+ (mysql-free-result res-ptr)))
(error 'clsql-sql-error
:database database
:expression query-expression
:errno (mysql-errno mysql-ptr)
:error (mysql-error-string mysql-ptr))))))
+(defmethod database-execute-command (sql-expression (database mysql-database))
+ (uffi:with-cstring (sql-native sql-expression)
+ (let ((mysql-ptr (database-mysql-ptr database)))
+ (declare (type mysql-mysql-ptr-def mysql-ptr))
+ (if (zerop (mysql-query mysql-ptr sql-native))
+ t
+ (error 'clsql-sql-error
+ :database database
+ :expression sql-expression
+ :errno (mysql-errno mysql-ptr)
+ :error (mysql-error-string mysql-ptr))))))
-(defmethod database-query-result-set (query-expression (database mysql-database)
- &key full-set field-types)
+(defstruct mysql-result-set
+ (res-ptr (uffi:make-null-pointer 'mysql-mysql-res)
+ :type mysql-mysql-res-ptr-def)
+ (types nil)
+ (num-fields nil :type fixnum)
+ (full-set nil :type boolean))
+
+
+(defmethod database-query-result-set (query-expression
+ (database mysql-database)
+ &key full-set types)
(uffi:with-cstring (query-native query-expression)
(let ((mysql-ptr (database-mysql-ptr database)))
(declare (type mysql-mysql-ptr-def mysql-ptr))
(mysql-use-result mysql-ptr))))
(declare (type mysql-mysql-res-ptr-def res-ptr))
(if (not (uffi:null-pointer-p res-ptr))
- (if full-set
- (values (make-mysql-result-set :res-ptr res-ptr :full-set t
- :field-types field-types)
- (mysql-num-fields res-ptr)
- (mysql-num-rows res-ptr))
- (values (make-mysql-result-set :res-ptr res-ptr)
- (mysql-num-fields res-ptr)))
- (error 'clsql-sql-error
+ (let* ((num-fields (mysql-num-fields res-ptr))
+ (result-set (make-mysql-result-set
+ :res-ptr res-ptr
+ :num-fields num-fields
+ :full-set full-set
+ :types
+ (canonicalize-types
+ types num-fields
+ res-ptr))))
+ (if full-set
+ (values result-set
+ num-fields
+ (mysql-num-rows res-ptr))
+ (values result-set
+ num-fields)))
+ (error 'clsql-sql-error
:database database
:expression query-expression
:errno (mysql-errno mysql-ptr)
:errno (mysql-errno mysql-ptr)
:error (mysql-error-string mysql-ptr))))))
+(defmethod database-dump-result-set (result-set (database mysql-database))
+ (mysql-free-result (mysql-result-set-res-ptr result-set))
+ t)
+
+
+(defmethod database-store-next-row (result-set (database mysql-database) list)
+ (let* ((res-ptr (mysql-result-set-res-ptr result-set))
+ (row (mysql-fetch-row res-ptr))
+ (types (mysql-result-set-types result-set)))
+ (declare (type mysql-mysql-res-ptr-def res-ptr)
+ (type mysql-row-def row))
+ (unless (uffi:null-pointer-p row)
+ (loop for i from 0 below (mysql-result-set-num-fields result-set)
+ for rest on list
+ do
+ (setf (car rest)
+ (convert-raw-field
+ (uffi:deref-array row 'mysql-row i)
+ types
+ i)))
+ list)))
+
+(when (clsql-base-sys:database-type-library-loaded :mysql)
+ (clsql-base-sys:initialize-database-type :database-type :mysql)
+ (pushnew :mysql cl:*features*))
projects / clsql.git / blobdiff