X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=db-mysql%2Fmysql-sql.lisp;h=b84431ced8fccd1abd9fd06d1d0f2464e67ca3b2;hb=31507a81fff1da3460625fbc07107de931907a8e;hp=dd623033013e7952bf9140a3f0cabe99030ba94c;hpb=9bbed78051e80e6ab76ae47834136035602bbbf1;p=clsql.git diff --git a/db-mysql/mysql-sql.lisp b/db-mysql/mysql-sql.lisp index dd62303..b84431c 100644 --- a/db-mysql/mysql-sql.lisp +++ b/db-mysql/mysql-sql.lisp @@ -14,7 +14,7 @@ ;;;; ************************************************************************* (defpackage #:clsql-mysql - (:use #:common-lisp #:clsql-base #:mysql #:clsql-uffi) + (:use #:common-lisp #:clsql-sys #:mysql #:clsql-uffi) (:export #:mysql-database) (:documentation "This is the CLSQL interface to MySQL.")) @@ -99,11 +99,11 @@ (let ((mysql-ptr (mysql-init (uffi:make-null-pointer 'mysql-mysql))) (socket nil)) (if (uffi:null-pointer-p mysql-ptr) - (error 'clsql-connect-error + (error 'sql-connection-error :database-type database-type :connection-spec connection-spec - :errno (mysql-errno mysql-ptr) - :error (mysql-error-string mysql-ptr)) + :error-id (mysql-errno mysql-ptr) + :message (mysql-error-string mysql-ptr)) (uffi:with-cstrings ((host-native host) (user-native user) (password-native password) @@ -117,11 +117,11 @@ db-native 0 socket-native 0)) (progn (setq error-occurred t) - (error 'clsql-connect-error + (error 'sql-connection-error :database-type database-type :connection-spec connection-spec - :errno (mysql-errno mysql-ptr) - :error (mysql-error-string mysql-ptr))) + :error-id (mysql-errno mysql-ptr) + :message (mysql-error-string mysql-ptr))) (make-instance 'mysql-database :name (database-name-from-spec connection-spec database-type) @@ -173,16 +173,16 @@ (when field-names (result-field-names num-fields res-ptr)))) (mysql-free-result res-ptr)) - (error 'clsql-sql-error + (error 'sql-database-data-error :database database :expression query-expression - :errno (mysql-errno mysql-ptr) - :error (mysql-error-string mysql-ptr)))) - (error 'clsql-sql-error + :error-id (mysql-errno mysql-ptr) + :message (mysql-error-string mysql-ptr)))) + (error 'sql-database-data-error :database database :expression query-expression - :errno (mysql-errno mysql-ptr) - :error (mysql-error-string mysql-ptr)))))) + :error-id (mysql-errno mysql-ptr) + :message (mysql-error-string mysql-ptr)))))) (defmethod database-execute-command (sql-expression (database mysql-database)) (uffi:with-cstring (sql-native sql-expression) @@ -191,11 +191,11 @@ (if (zerop (mysql-real-query mysql-ptr sql-native (length sql-expression))) t - (error 'clsql-sql-error + (error 'sql-database-data-error :database database :expression sql-expression - :errno (mysql-errno mysql-ptr) - :error (mysql-error-string mysql-ptr)))))) + :error-id (mysql-errno mysql-ptr) + :message (mysql-error-string mysql-ptr)))))) (defstruct mysql-result-set @@ -233,16 +233,16 @@ (mysql-num-rows res-ptr)) (values result-set num-fields))) - (error 'clsql-sql-error + (error 'sql-database-data-error :database database :expression query-expression - :errno (mysql-errno mysql-ptr) - :error (mysql-error-string mysql-ptr)))) - (error 'clsql-sql-error + :error-id (mysql-errno mysql-ptr) + :message (mysql-error-string mysql-ptr)))) + (error 'sql-database-data-error :database database :expression query-expression - :errno (mysql-errno mysql-ptr) - :error (mysql-error-string mysql-ptr)))))) + :error-id (mysql-errno mysql-ptr) + :message (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)) @@ -392,33 +392,31 @@ (defmethod database-create (connection-spec (type (eql :mysql))) (destructuring-bind (host name user password) connection-spec (multiple-value-bind (output status) - (clsql-base:command-output "mysqladmin create -u~A -p~A -h~A ~A" + (clsql-sys:command-output "mysqladmin create -u~A -p~A -h~A ~A" user password (if host host "localhost") name) (if (or (not (eql 0 status)) (and (search "failed" output) (search "error" output))) - (error 'clsql-access-error - :connection-spec connection-spec - :database-type type - :error - (format nil "database-create failed: ~A" output)) - t)))) + (error 'sql-database-error + :message + (format nil "mysql database creation failed with connection-spec ~A." + connection-spec)) + t)))) (defmethod database-destroy (connection-spec (type (eql :mysql))) (destructuring-bind (host name user password) connection-spec (multiple-value-bind (output status) - (clsql-base:command-output "mysqladmin drop -f -u~A -p~A -h~A ~A" + (clsql-sys:command-output "mysqladmin drop -f -u~A -p~A -h~A ~A" user password (if host host "localhost") name) (if (or (not (eql 0 status)) (and (search "failed" output) (search "error" output))) - (error 'clsql-access-error - :connection-spec connection-spec - :database-type type - :error - (format nil "database-destroy failed: ~A" output)) + (error 'sql-database-error + :message + (format nil "mysql database deletion failed with connection-spec ~A." + connection-spec)) t)))) (defmethod database-probe (connection-spec (type (eql :mysql))) @@ -432,11 +430,130 @@ (let ((database (database-connect (list host "mysql" user password) type))) (unwind-protect (progn - (setf (slot-value database 'clsql-base::state) :open) + (setf (slot-value database 'clsql-sys::state) :open) (mapcar #'car (database-query "show databases" database :auto nil))) (progn (database-disconnect database) - (setf (slot-value database 'clsql-base::state) :closed)))))) + (setf (slot-value database 'clsql-sys::state) :closed)))))) + + +;;; Prepared statements + +(defclass mysql-stmt () + ((database :initarg :database :reader database) + (stmt :initarg :stmt :accessor stmt) + (input-bind :initarg :input-bind :reader input-bind) + (output-bind :initarg :output-bind :reader output-bind) + (types :initarg :types :reader types) + (result-set :initarg :result-set :reader result-set) + (num-fields :initarg :num-fields :reader num-fields) + (field-names :initarg :field-names :accessor stmt-field-names) + (result-types :initarg :result-types :reader result-types))) + +(defun clsql-type->mysql-type (type) + (cond + ((in type :null) mysql-field-types#null) + ((in type :int :integer) mysql-field-types#long) + ((in type :short) mysql-field-types#short) + ((in type :bigint) mysql-field-types#longlong) + ((in type :float :double :number) mysql-field-types#double) + ((and (consp type) (in (car type) :char :varchar)) mysql-field-types#var-string) + (t + (error 'sql-user-error + :message + (format nil "Unknown clsql type ~A." type))))) + +(defmethod database-prepare (sql-stmt types (database mysql-database) result-types field-names) + (let* ((mysql-ptr (database-mysql-ptr database)) + (stmt (mysql-stmt-init mysql-ptr))) + (when (uffi:null-pointer-p stmt) + (error 'sql-database-error + :error-id (mysql-errno mysql-ptr) + :message (mysql-error-string mysql-ptr))) + + (uffi:with-cstring (native-query sql-stmt) + (unless (zerop (mysql-stmt-prepare stmt native-query (length sql-stmt))) + (error 'sql-database-error + :error-id (mysql-errno mysql-ptr) + :message (mysql-error-string mysql-ptr)))) + + (unless (= (mysql-stmt-param-count stmt) (length types)) + (error 'sql-database-error + :message + (format nil "Mysql param count (~D) does not match number of types (~D)" + (mysql-stmt-param-count stmt) (length types)))) + + (let ((rs (mysql-stmt-result-metadata stmt))) + (when (uffi:null-pointer-p rs) + (error 'sql-database-error + :message "NULL result metadata")) + (make-instance 'mysql-stmt + :database database + :stmt stmt + :num-fields (mysql-num-fields rs) + :input-bind (uffi:allocate-foreign-object mysql-bind (length types)) + :output-bind (uffi:allocate-foreign-object mysql-bind (mysql-num-fields rs)) + :result-set rs + :result-types result-types + :types (mapcar 'clsql-type->mysql-type types) + :field-names field-names)))) + +(defmethod database-bind-parameter ((stmt mysql-stmt) position value) + ;; FIXME: will need to allocate bind structure. This should probably be + ;; done in C since the API is not mature and may change + (let ((binding (uffi:deref-array (input-bind stmt) '(:array mysql-bind) (1- position))) + (type (nth (1- position) (types stmt)))) + (setf (uffi:get-slot-value binding 'mysql-bind 'length) 0) + (cond + ((null value) + (setf (uffi:get-slot-value binding 'mysql-bind 'is-null) 1)) + (t + (setf (uffi:get-slot-value binding 'mysql-bind 'is-null) 0) + (setf (uffi:get-slot-value binding 'mysql-bind 'buffer-type) type) + (case type + (#.mysql-field-types#long + (let ((ptr (uffi:allocate-foreign-object :long))) + (setf (uffi:deref-pointer ptr :long) value) + (setf (uffi:get-slot-value binding 'mysql-bind 'buffer) ptr))) + ))))) + +(defmethod database-run-prepared ((stmt mysql-stmt)) + (unless (zerop (mysql-stmt-bind-param (stmt stmt) (input-bind stmt))) + (error 'sql-database-error + :error-id (mysql-stmt-errno (stmt stmt)) + :message (uffi:convert-from-cstring + (mysql-stmt-error (stmt stmt))))) + (unless (zerop (mysql-stmt-execute (stmt stmt))) + (error 'sql-database-error + :error-id (mysql-stmt-errno (stmt stmt)) + :message (uffi:convert-from-cstring + (mysql-stmt-error (stmt stmt))))) + (let ((field-vec (mysql-fetch-fields (result-set stmt)))) + (dotimes (i (num-fields (result-set stmt))) + (declare (fixnum i)) + (let* ((field (uffi:deref-array field-vec '(:array mysql-field) i)) + (type (uffi:get-slot-value field 'mysql-field 'type)) + (binding (uffi:deref-array (output-bind stmt) '(:array mysql-bind) i))) + (setf (uffi:get-slot-value binding 'mysql-bind 'buffer-type) type) + (case type + (#.mysql-field-types#var-string + (setf (uffi:get-slot-value binding 'mysql-bind 'buffer-length) 1024) + (setf (uffi:get-slot-value binding 'mysql-bind 'buffer) + (uffi:allocate-foreign-object :unsigned-char 1024))) + (t + (setf (uffi:get-slot-value binding 'mysql-bind 'buffer-length) 0)))))) + (unless (zerop (mysql-stmt-bind-result (stmt stmt) (output-bind stmt))) + (error 'sql-database-error + :error-id (mysql-stmt-errno (stmt stmt)) + :message (uffi:convert-from-cstring + (mysql-stmt-error (stmt stmt)))))) + + +(defmethod database-free-prepared ((stmt mysql-stmt)) + (with-slots (stmt) stmt + (mysql-stmt-close stmt)) + ) + ;;; Database capabilities @@ -444,20 +561,27 @@ t) (defmethod db-type-has-views? ((db-type (eql :mysql))) - ;; MySQL 4.1 will apparently have views, need to check *mysql-client-info* - nil) + #+mysql-client-v5.1 t + #-mysql-client-v5.1 nil) (defmethod db-type-has-subqueries? ((db-type (eql :mysql))) - ;; MySQL 4.1 will apparently have subqueries, need to check *mysql-client-info* - nil) + #+mysql-client-v4.1 t + #-mysql-client-v4.1 nil) (defmethod db-type-has-boolean-where? ((db-type (eql :mysql))) nil) +(defmethod db-type-has-union? ((db-type (eql :mysql))) + (not (eql (schar mysql::*mysql-client-info* 0) #\3))) + (defmethod db-type-transaction-capable? ((db-type (eql :mysql)) database) (let ((tuple (car (database-query "SHOW VARIABLES LIKE 'HAVE_INNODB'" database :auto nil)))) (and tuple (string-equal "YES" (second tuple))))) -(when (clsql-base:database-type-library-loaded :mysql) - (clsql-base:initialize-database-type :database-type :mysql)) +(defmethod db-type-has-prepared-stmt? ((db-type (eql :mysql))) + #+mysql-client-v4.1 t + #-mysql-client-v4.1 nil) + +(when (clsql-sys:database-type-library-loaded :mysql) + (clsql-sys:initialize-database-type :database-type :mysql))