(in-package #:clsql-mysql)
+;; if we have :sb-unicode, UFFI will treat :cstring as a UTF-8 string
+(defun expression-length (query-expression)
+ (length #+sb-unicode (sb-ext:string-to-octets query-expression
+ :external-format :utf8)
+ #-sb-unicode query-expression))
+
;;; Field conversion functions
(defun result-field-names (num-fields res-ptr)
(dotimes (i num-fields)
(declare (fixnum i))
(let* ((field (uffi:deref-array field-vec '(:array mysql-field) i))
- (type (uffi:get-slot-value field 'mysql-field 'type)))
+ (flags (uffi:get-slot-value field 'mysql-field 'mysql::flags))
+ (unsigned (plusp (logand flags 32)))
+ (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#int24)
+ (if unsigned
+ :uint32
+ :int32))
+ (#.mysql-field-types#long
+ (if unsigned
+ :uint
+ :int))
+ (#.mysql-field-types#longlong
+ (if unsigned
+ :uint64
+ :int64))
((#.mysql-field-types#double
#.mysql-field-types#float
#.mysql-field-types#decimal)
: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
+ (check-connection-spec connection-spec database-type
+ (host db user password &optional port))
+ (destructuring-bind (host db user password &optional port) connection-spec
(declare (ignore password))
(concatenate 'string
- (if host host "localhost")
+ (etypecase host
+ (null "localhost")
+ (pathname (namestring host))
+ (string host))
+ (if port
+ (concatenate 'string
+ ":"
+ (etypecase port
+ (integer (write-to-string port))
+ (string port)))
+ "")
"/" db "/" user)))
(defmethod database-connect (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
+ (check-connection-spec connection-spec database-type
+ (host db user password &optional port))
+ (destructuring-bind (host db user password &optional port) connection-spec
(let ((mysql-ptr (mysql-init (uffi:make-null-pointer 'mysql-mysql)))
(socket nil))
(if (uffi:null-pointer-p mysql-ptr)
(if (uffi:null-pointer-p
(mysql-real-connect
mysql-ptr host-native user-native password-native
- db-native 0 socket-native 0))
+ db-native
+ (etypecase port
+ (null 0)
+ (integer port)
+ (string (parse-integer port)))
+ socket-native 0))
(progn
(setq error-occurred t)
(error 'sql-connection-error
(let ((mysql-ptr (database-mysql-ptr database)))
(uffi:with-cstring (query-native query-expression)
(if (zerop (mysql-real-query mysql-ptr query-native
- (length query-expression)))
+ (expression-length query-expression)))
(let ((res-ptr (mysql-use-result mysql-ptr)))
(if res-ptr
(unwind-protect
(let ((mysql-ptr (database-mysql-ptr database)))
(declare (type mysql-mysql-ptr-def mysql-ptr))
(if (zerop (mysql-real-query mysql-ptr sql-native
- (length sql-expression)))
+ (expression-length sql-expression)))
t
(error 'sql-database-data-error
:database database
(let ((mysql-ptr (database-mysql-ptr database)))
(declare (type mysql-mysql-ptr-def mysql-ptr))
(if (zerop (mysql-real-query mysql-ptr query-native
- (length query-expression)))
+ (expression-length query-expression)))
(let ((res-ptr (if full-set
(mysql-store-result mysql-ptr)
(mysql-use-result mysql-ptr))))
(mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database))))
(defmethod database-sequence-last (sequence-name (database mysql-database))
- (declare (ignore sequence-name)))
+ (without-interrupts
+ (caar (database-query
+ (concatenate 'string "SELECT id from "
+ (%sequence-name-to-table sequence-name))
+ database :auto nil))))
(defmethod database-create (connection-spec (type (eql :mysql)))
- (destructuring-bind (host name user password) connection-spec
+ (destructuring-bind (host name user password &optional port) connection-spec
(multiple-value-bind (output status)
- (clsql-sys:command-output "mysqladmin create -u~A -p~A -h~A ~A"
+ (clsql-sys:command-output "mysqladmin create -u~A -p~A -h~A~@[ -P~A~] ~A"
user password
(if host host "localhost")
+ port name
name)
(if (or (not (eql 0 status))
(and (search "failed" output) (search "error" output)))
t))))
(defmethod database-destroy (connection-spec (type (eql :mysql)))
- (destructuring-bind (host name user password) connection-spec
+ (destructuring-bind (host name user password &optional port) connection-spec
(multiple-value-bind (output status)
- (clsql-sys: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~@[ -P~A~] ~A"
user password
(if host host "localhost")
- name)
+ port name)
(if (or (not (eql 0 status))
(and (search "failed" output) (search "error" output)))
(error 'sql-database-error
t))
(defmethod database-list (connection-spec (type (eql :mysql)))
- (destructuring-bind (host name user password) connection-spec
+ (destructuring-bind (host name user password &optional port) connection-spec
(declare (ignore name))
- (let ((database (database-connect (list host "mysql" user password) type)))
+ (let ((database (database-connect (list host "mysql" user password port) type)))
(unwind-protect
(progn
(setf (slot-value database 'clsql-sys::state) :open)
:message (mysql-error-string mysql-ptr)))
(uffi:with-cstring (native-query sql-stmt)
- (unless (zerop (mysql-stmt-prepare stmt native-query (length sql-stmt)))
+ (unless (zerop (mysql-stmt-prepare stmt native-query (expression-length sql-stmt)))
(mysql-stmt-close stmt)
(error 'sql-database-error
:error-id (mysql-errno mysql-ptr)
(print 'a)
(dotimes (i (length types))
(let* ((binding (uffi:deref-array input-bind '(:array mysql-bind) i)))
- (setf (uffi:get-slot-value binding 'mysql-bind 'buffer-type)
+ (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer-type)
(nth i mysql-types))
- (setf (uffi:get-slot-value binding 'mysql-bind 'buffer-length) 0)))
+ (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer-length) 0)))
(print 'b)
(unless (uffi:null-pointer-p rs)
(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 '(:array mysql-bind) i)))
- (setf (uffi:get-slot-value binding 'mysql-bind 'buffer-type) type)
+ (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer-type) type)
- (setf (uffi:get-slot-value binding 'mysql-bind 'buffer-length) 0)
- (setf (uffi:get-slot-value binding 'mysql-bind 'is-null)
+ (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer-length) 0)
+ #+need-to-allocate-foreign-object-for-this
+ (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::is-null)
(+ i (uffi:pointer-address is-null-ptr)))
+ #+need-to-allocate-foreign-object-for-this
(setf (uffi:get-slot-value binding 'mysql-bind 'length)
(+ (* i 8) (uffi:pointer-address length-ptr)))
((#.mysql-field-types#var-string #.mysql-field-types#string
#.mysql-field-types#tiny-blob #.mysql-field-types#blob
#.mysql-field-types#medium-blob #.mysql-field-types#long-blob)
- (setf (uffi:get-slot-value binding 'mysql-bind 'buffer-length) 1024)
- (setf (uffi:get-slot-value binding 'mysql-bind 'buffer)
+ (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer-length) 1024)
+ (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer)
(uffi:allocate-foreign-object :unsigned-char 1024)))
(#.mysql-field-types#tiny
- (setf (uffi:get-slot-value binding 'mysql-bind 'buffer)
+ (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer)
(uffi:allocate-foreign-object :byte)))
(#.mysql-field-types#short
- (setf (uffi:get-slot-value binding 'mysql-bind 'buffer)
+ (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer)
(uffi:allocate-foreign-object :short)))
(#.mysql-field-types#long
- (setf (uffi:get-slot-value binding 'mysql-bind 'buffer)
+ (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer)
;; segfaults if supply :int on amd64
(uffi:allocate-foreign-object :long)))
#+64bit
(#.mysql-field-types#longlong
- (setf (uffi:get-slot-value binding 'mysql-bind 'buffer)
+ (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer)
(uffi:allocate-foreign-object :long)))
(#.mysql-field-types#float
- (setf (uffi:get-slot-value binding 'mysql-bind 'buffer)
+ (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer)
(uffi:allocate-foreign-object :float)))
(#.mysql-field-types#double
- (setf (uffi:get-slot-value binding 'mysql-bind 'buffer)
+ (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer)
(uffi:allocate-foreign-object :double)))
((#.mysql-field-types#time #.mysql-field-types#date
#.mysql-field-types#datetime #.mysql-field-types#timestamp)
(setf (uffi:deref-array (is-null-ptr stmt) '(:array :byte) (1- position)) 0))
(case type
(#.mysql-field-types#long
- (setf (uffi:get-slot-value binding 'mysql-bind 'buffer) value))
+ (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer) value))
(t
(warn "Unknown input bind type ~D." type))
)))))
(uffi:deref-array (is-null-ptr stmt) '(:array :byte) i))))))
(unless is-null
(let* ((bind (uffi:deref-array (output-bind stmt) '(:array mysql-bind) i))
- (type (uffi:get-slot-value bind 'mysql-bind 'buffer-type))
- (buffer (uffi:get-slot-value bind 'mysql-bind 'buffer)))
+ (type (uffi:get-slot-value bind 'mysql-bind 'mysql::buffer-type))
+ (buffer (uffi:get-slot-value bind 'mysql-bind 'mysql::buffer)))
(case type
((#.mysql-field-types#var-string #.mysql-field-types#string
#.mysql-field-types#tiny-blob #.mysql-field-types#blob