(defpackage #:clsql-mysql
(:use #:common-lisp #:clsql-sys #:mysql #:clsql-uffi)
(:export #:mysql-database)
+ (:import-from :clsql-sys
+ :escaped :unescaped :combine-database-identifiers
+ :escaped-database-identifier :unescaped-database-identifier :database-identifier
+ :%sequence-name-to-table :%table-name-to-sequence-name)
(:documentation "This is the CLSQL interface to MySQL."))
(in-package #:clsql-mysql)
(defmethod database-name-from-spec (connection-spec (database-type (eql :mysql)))
(check-connection-spec connection-spec database-type
(host db user password &optional port options))
- (destructuring-bind (host db user password &optional port) connection-spec
- (declare (ignore password))
+ (destructuring-bind (host db user password &optional port options) connection-spec
+ (declare (ignore password options))
(concatenate 'string
(etypecase host
(null "localhost")
(let ((option-code (lookup-option-code option)))
(when option-code
(mysql-options mysql-ptr option-code uffi:+null-cstring-pointer+)))
- (destructuring-bind (name value) option
+ (destructuring-bind (name . value) option
(let ((option-code (lookup-option-code name)))
(when option-code
(case (lookup-option-type name)
(:none
(mysql-options mysql-ptr option-code uffi:+null-cstring-pointer+))
(:char-ptr
- (uffi:with-foreign-string (fs value)
- (mysql-options mysql-ptr option-code fs)))
+ (if (stringp value)
+ (uffi:with-foreign-string (fs value)
+ (mysql-options mysql-ptr option-code fs))
+ (warn "Expecting string argument for mysql option ~A, got ~A ~
+- ignoring.~%"
+ name value)))
(:uint-ptr
- (uffi:with-foreign-object (fo :unsigned-int)
- (setf (uffi:deref-pointer fo :unsigned-int) value)
- (mysql-options mysql-ptr option-code fo)))
+ (if (integerp value)
+ (uffi:with-foreign-object (fo :unsigned-int)
+ (setf (uffi:deref-pointer fo :unsigned-int) value)
+ (mysql-options mysql-ptr option-code fo))
+ (warn "Expecting integer argument for mysql option ~A, got ~A ~
+- ignoring.~%"
+ name value)))
(:boolean-ptr
(uffi:with-foreign-object (fo :byte)
(setf (uffi:deref-pointer fo :byte)
- (if (or (zerop value) (null value))
- 0
- 1))
+ (case value
+ ((nil 0) 0)
+ (t 1)))
(mysql-options mysql-ptr option-code fo)))))))))))
(defmethod database-connect (connection-spec (database-type (eql :mysql)))
(defmethod database-query (query-expression (database mysql-database)
result-types field-names)
- (declare (optimize (speed 3) (safety 0) (debug 0) (space 0)))
- (let ((mysql-ptr (database-mysql-ptr database)))
- (declare (type mysql-mysql-ptr-def mysql-ptr))
+ (declare (optimize (speed 3)))
+ (let ((mysql-ptr (database-mysql-ptr database))
+ (results nil) ;; all the results and column-names in reverse-order
+ (res-ptr nil)
+ (num-fields 0))
+ (declare (type mysql-mysql-ptr-def mysql-ptr)
+ (type (or null mysql-mysql-res-ptr-def) res-ptr)
+ (fixnum num-fields))
(when (database-execute-command query-expression database)
- (let ((res-ptr (mysql-use-result mysql-ptr)))
- (declare (type mysql-mysql-res-ptr-def res-ptr))
- (if (and res-ptr (not (uffi:null-pointer-p res-ptr)))
- (unwind-protect
- (let ((num-fields (mysql-num-fields res-ptr)))
- (declare (fixnum num-fields))
- (setq result-types (canonicalize-types
- result-types res-ptr))
- (values
- (loop for row = (mysql-fetch-row res-ptr)
- for lengths = (mysql-fetch-lengths res-ptr)
- until (uffi:null-pointer-p row)
- collect
- (do* ((rlist (make-list num-fields))
- (i 0 (1+ i))
- (pos rlist (cdr pos)))
- ((= i num-fields) rlist)
- (declare (fixnum i))
- (setf (car pos)
- (convert-raw-field
- (uffi:deref-array row '(:array
- (* :unsigned-char))
- i)
- (nth i result-types)
- :length
- (uffi:deref-array lengths '(:array :unsigned-long) i)
- :encoding (encoding database)))))
- (when field-names
- (result-field-names res-ptr))))
- (mysql-free-result res-ptr))
- (unless (zerop (mysql-errno mysql-ptr))
- ;;from http://dev.mysql.com/doc/refman/5.0/en/mysql-field-count.html
- ;; if mysql_use_result or mysql_store_result return a null ptr,
- ;; we use a mysql_errno check to see if it had a problem or just
- ;; was a query without a result. If no error, just return nil.
- (error 'sql-database-data-error
- :database database
- :expression query-expression
- :error-id (mysql-errno mysql-ptr)
- :message (mysql-error-string mysql-ptr))))))))
+ (labels
+ ((get-row (row lengths)
+ "Pull a single row value from the results"
+ (loop for i from 0 below num-fields
+ collect
+ (convert-raw-field
+ (uffi:deref-array row '(:array (* :unsigned-char))
+ (the fixnum i))
+ (nth i result-types)
+ :length
+ (uffi:deref-array lengths '(:array :unsigned-long)
+ (the fixnum i))
+ :encoding (encoding database))))
+ (get-result-rows ()
+ "get all the rows out of the now valid results set"
+ (loop for row = (mysql-fetch-row res-ptr)
+ for lengths = (mysql-fetch-lengths res-ptr)
+ until (uffi:null-pointer-p row)
+ collect (get-row row lengths)))
+ (do-result-set ()
+ "for a mysql-ptr, grab and return a results set"
+ (setf res-ptr (mysql-use-result mysql-ptr))
+ (cond
+ ((or (null res-ptr) (uffi:null-pointer-p res-ptr))
+ (unless (zerop (mysql-errno mysql-ptr))
+ ;;from http://dev.mysql.com/doc/refman/5.0/en/mysql-field-count.html
+ ;; if mysql_use_result or mysql_store_result return a null ptr,
+ ;; we use a mysql_errno check to see if it had a problem or just
+ ;; was a query without a result. If no error, just return nil.
+ (error 'sql-database-data-error
+ :database database
+ :expression query-expression
+ :error-id (mysql-errno mysql-ptr)
+ :message (mysql-error-string mysql-ptr))))
+ (t
+ (unwind-protect
+ (progn (setf num-fields (mysql-num-fields res-ptr)
+ result-types (canonicalize-types
+ result-types res-ptr))
+ (push (get-result-rows) results)
+ (push (when field-names
+ (result-field-names res-ptr))
+ results))
+ (mysql-free-result res-ptr))))))
+
+ (loop
+ do (do-result-set)
+ while (let ((next (mysql-next-result mysql-ptr)))
+ (case next
+ (0 t) ;Successful and there are more results
+ (-1 nil) ;Successful and there are no more results
+ (t nil) ;errors
+ )))
+ (values-list (nreverse results))))))
(defstruct mysql-result-set
(defmethod database-query-result-set ((query-expression string)
(database mysql-database)
&key full-set result-types)
+ ;; TODO: REFACTOR THIS IN TERMS OF database-query or vice-versa
+ ;; This doesnt seem to free database results reliably, dont think
+ ;; that we should allow that particularly, OTOH, dont know how
+ ;; we support cursoring without it
(let ((mysql-ptr (database-mysql-ptr database)))
(declare (type mysql-mysql-ptr-def mysql-ptr))
(when (database-execute-command query-expression database)
(declare (ignore owner))
(do ((results nil)
(rows (database-query
- (format nil "SHOW INDEX FROM ~A" table)
+ (format nil "SHOW INDEX FROM ~A" (escaped-database-identifier
+ table database))
database nil nil)
(cdr rows)))
((null rows) (nreverse results))
(unless (find col results :test #'string-equal)
(push col results)))))
-(defmethod database-list-attributes ((table string) (database mysql-database)
- &key (owner nil))
+(defmethod database-list-attributes ((table clsql-sys::%database-identifier)
+ (database mysql-database)
+ &key (owner nil)
+ &aux (table (unescaped-database-identifier table)))
(declare (ignore owner))
(mapcar #'car
(database-query
- (format nil "SHOW COLUMNS FROM ~A" table)
+ (format nil "SHOW COLUMNS FROM ~A" (escaped-database-identifier
+ table database))
database nil nil)))
-(defmethod database-attribute-type (attribute (table string)
+(defmethod database-attribute-type ((attribute clsql-sys::%database-identifier)
+ (table clsql-sys::%database-identifier)
(database mysql-database)
- &key (owner nil))
+ &key (owner nil)
+ &aux (table (unescaped-database-identifier table))
+ (attribute (unescaped-database-identifier attribute)))
(declare (ignore owner))
(let ((row (car (database-query
(format nil
- "SHOW COLUMNS FROM ~A LIKE '~A'" table attribute)
+ "SHOW COLUMNS FROM ~A LIKE '~A'"
+ (escaped-database-identifier
+ table database)
+ (unescaped-database-identifier
+ attribute database))
database nil nil))))
(let* ((raw-type (second row))
(null (third row))
;;; Sequence functions
-(defun %sequence-name-to-table (sequence-name)
- (concatenate 'string "_CLSQL_SEQ_" (sql-escape sequence-name)))
-
-(defun %table-name-to-sequence-name (table-name)
- (and (>= (length table-name) 11)
- (string-equal (subseq table-name 0 11) "_CLSQL_SEQ_")
- (subseq table-name 11)))
-
(defmethod database-create-sequence (sequence-name
(database mysql-database))
- (let ((table-name (%sequence-name-to-table sequence-name)))
+ (let ((table-name (%sequence-name-to-table sequence-name database)))
(database-execute-command
(concatenate 'string "CREATE TABLE " table-name
" (id int NOT NULL PRIMARY KEY AUTO_INCREMENT)")
(defmethod database-drop-sequence (sequence-name
(database mysql-database))
(database-execute-command
- (concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name))
+ (concatenate 'string "DROP TABLE "
+ (%sequence-name-to-table sequence-name database))
database))
(defmethod database-list-sequences ((database mysql-database)
(declare (ignore owner))
(mapcan #'(lambda (s)
(let ((sn (%table-name-to-sequence-name (car s))))
- (and sn (list sn))))
+ (and sn (list (car s) sn))))
(database-query "SHOW TABLES" database nil nil)))
(defmethod database-set-sequence-position (sequence-name
(position integer)
(database mysql-database))
(database-execute-command
- (format nil "UPDATE ~A SET id=~A" (%sequence-name-to-table sequence-name)
+ (format nil "UPDATE ~A SET id=~A" (%sequence-name-to-table sequence-name database)
position)
database)
(mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database)))
(defmethod database-sequence-next (sequence-name (database mysql-database))
(without-interrupts
(database-execute-command
- (concatenate 'string "UPDATE " (%sequence-name-to-table sequence-name)
+ (concatenate 'string "UPDATE " (%sequence-name-to-table sequence-name database)
" SET id=LAST_INSERT_ID(id+1)")
database)
(mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database))))
(without-interrupts
(caar (database-query
(concatenate 'string "SELECT id from "
- (%sequence-name-to-table sequence-name))
+ (%sequence-name-to-table sequence-name database))
database :auto nil))))
+(defmethod database-last-auto-increment-id ((database mysql-database) table column)
+ (declare (ignore table column))
+ (car (query "SELECT LAST_INSERT_ID();"
+ :flatp t :field-names nil
+ :database database)))
+
(defmethod database-create (connection-spec (type (eql :mysql)))
(destructuring-bind (host name user password) connection-spec
(let ((database (database-connect (list host "" user password)
t))
(defmethod database-list (connection-spec (type (eql :mysql)))
- (destructuring-bind (host name user password &optional port) connection-spec
+ (destructuring-bind (host name user password &optional port options) connection-spec
+ (declare (ignore options))
(let ((database (database-connect (list host (or name "mysql")
user password port) type)))
(unwind-protect