├── .gitattributes ├── .gitignore ├── cl-mysql-test.asd ├── cl-mysql.asd ├── cl-mysql.mbd ├── connection.lisp ├── integration-test.lisp ├── mysql.lisp ├── package.lisp ├── package.sh ├── pool.lisp ├── prepare.lisp ├── system.lisp ├── test-pool.lisp ├── test-prepare.lisp ├── test.lisp └── thread.lisp /.gitattributes: -------------------------------------------------------------------------------- 1 | *.asd ident 2 | *.lisp ident 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.[ao] 3 | .*.swp 4 | .swp 5 | *.fasl 6 | -------------------------------------------------------------------------------- /cl-mysql-test.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp -*- 2 | ;;;; $Id: e35ba862781d090fb5e145e2e7744f5bae409405 $ 3 | ;;;; 4 | ;;;; Copyright (c) 2009 Steve Knight 5 | ;;;; 6 | ;;;; Permission is hereby granted, free of charge, to any person obtaining 7 | ;;;; a copy of this software and associated documentation files (the 8 | ;;;; "Software"), to deal in the Software without restriction, including 9 | ;;;; without limitation the rights to use, copy, modify, merge, publish, 10 | ;;;; distribute, sublicense, and/or sell copies of the Software, and to 11 | ;;;; permit persons to whom the Software is furnished to do so, subject to 12 | ;;;; the following conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 19 | ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 21 | ;;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 22 | ;;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 23 | ;;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 24 | ;;;; 25 | (asdf:defsystem #:cl-mysql-test 26 | :depends-on (#:cl-mysql 27 | #:stefil) 28 | :components ((:file "test") 29 | (:file "test-pool") 30 | (:file "test-prepare") 31 | (:file "integration-test")) 32 | :serial t) 33 | -------------------------------------------------------------------------------- /cl-mysql.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp -*- 2 | ;;;; $Id: a739309aa2c2fd8f12a1a5b70f569242c62e21d9 $ 3 | ;;;; 4 | ;;;; Copyright (c) 2009 Steve Knight 5 | ;;;; 6 | ;;;; Permission is hereby granted, free of charge, to any person obtaining 7 | ;;;; a copy of this software and associated documentation files (the 8 | ;;;; "Software"), to deal in the Software without restriction, including 9 | ;;;; without limitation the rights to use, copy, modify, merge, publish, 10 | ;;;; distribute, sublicense, and/or sell copies of the Software, and to 11 | ;;;; permit persons to whom the Software is furnished to do so, subject to 12 | ;;;; the following conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 19 | ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 21 | ;;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 22 | ;;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 23 | ;;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 24 | ;;;; 25 | 26 | (asdf:defsystem #:cl-mysql 27 | :description "Common Lisp MySQL library bindings" 28 | :version "0.1" 29 | :author "Steve Knight " 30 | :maintainer "Steve Knight " 31 | :licence "MIT" 32 | :in-order-to ((test-op (load-op cl-mysql-test))) 33 | :perform (test-op :after (op c) 34 | (describe 35 | (funcall 36 | (intern "TEST" :cl-mysql-test)))) 37 | :serial t 38 | :components ((:file "system") 39 | (:file "thread") 40 | (:file "connection") 41 | (:file "pool") 42 | (:file "mysql") 43 | (:file "prepare") 44 | (:file "package")) 45 | :depends-on (#:cffi)) 46 | 47 | (defmethod operation-done-p 48 | ((o test-op) 49 | (c (eql (find-system 'cl-mysql))))) 50 | 51 | 52 | 53 | 54 | 55 | 56 | -------------------------------------------------------------------------------- /cl-mysql.mbd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp -*- 2 | ;;;; $Id: 1979f6357459652341a9079baf09b3672d726bb3 $ 3 | ;;;; 4 | ;;;; Copyright (c) 2009 Steve Knight 5 | ;;;; 6 | ;;;; Permission is hereby granted, free of charge, to any person obtaining 7 | ;;;; a copy of this software and associated documentation files (the 8 | ;;;; "Software"), to deal in the Software without restriction, including 9 | ;;;; without limitation the rights to use, copy, modify, merge, publish, 10 | ;;;; distribute, sublicense, and/or sell copies of the Software, and to 11 | ;;;; permit persons to whom the Software is furnished to do so, subject to 12 | ;;;; the following conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 19 | ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 21 | ;;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 22 | ;;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 23 | ;;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 24 | ;;;; 25 | (in-package :sysdef-user) 26 | 27 | (define-system :cl-mysql () 28 | (:author "Steve Knight ") 29 | (:version 0 1) 30 | (:licence "MIT") 31 | (:documentation "Common Lisp MySQL library bindings") 32 | (:serial t) 33 | (:components 34 | "system" 35 | "thread" 36 | "connection" 37 | "pool" 38 | "mysql" 39 | "package") 40 | (:needs :cffi)) 41 | -------------------------------------------------------------------------------- /connection.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp -*- 2 | ;;;; $Id: fda9d743da04b965d5bfdcfc602aa259845d2b98 $ 3 | ;;;; 4 | ;;;; Copyright (c) 2009 Steve Knight 5 | ;;;; 6 | ;;;; Permission is hereby granted, free of charge, to any person obtaining 7 | ;;;; a copy of this software and associated documentation files (the 8 | ;;;; "Software"), to deal in the Software without restriction, including 9 | ;;;; without limitation the rights to use, copy, modify, merge, publish, 10 | ;;;; distribute, sublicense, and/or sell copies of the Software, and to 11 | ;;;; permit persons to whom the Software is furnished to do so, subject to 12 | ;;;; the following conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 19 | ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 21 | ;;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 22 | ;;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 23 | ;;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 24 | ;;;; 25 | (in-package "CL-MYSQL-SYSTEM") 26 | 27 | (defparameter *type-map* (make-hash-table)) 28 | 29 | (defclass connectable () 30 | () 31 | (:documentation "The base class of connectability. CL-MYSQL functions operate on a 32 | connectable which is then subclassed into a single connection and a connection pool. 33 | Note that the connectable itself has no state.")) 34 | 35 | (defgeneric acquire (connectable &optional keyword) 36 | (:documentation "Calling aquire on a single connection returns itself, on a connection-pool it will return 37 | the first available connection. Note that the pool implementation of this method could block")) 38 | 39 | (defgeneric release (connectable &optional other-args) 40 | (:documentation "Calling release will place the connection back into the pool. If the pool has more 41 | connections than max-connections then releasing the connection will close it and deallocate it.")) 42 | 43 | (defclass connection (connectable) 44 | ((pointer :type t :initform (null-pointer) :accessor pointer :initarg :pointer) 45 | (result-set :type t :initform (null-pointer) :accessor result-set) 46 | (in-use :type (or null t) :initform nil :accessor in-use :initarg :in-use) 47 | (owner-pool :type t :reader owner-pool :initarg :owner-pool) 48 | (result-set-fields :type list :initform nil :accessor result-set-fields) 49 | (use-query-active :type (or null t) :initform nil :accessor use-query-active)) 50 | (:documentation "The slots necessary to manage a MySQL database connection.")) 51 | 52 | (defmethod (setf result-set) ((result-set t) (conn connection)) 53 | (setf (slot-value conn 'result-set) result-set) 54 | (set-field-names-and-types conn)) 55 | 56 | (defmethod process-result-set ((self connection) type-map) 57 | "Returns a CONS of all the data in the result set. Note that this method 58 | should only be called by the client if you originally sent :store NIL to 59 | query but then set :store to T when calling next-result-set." 60 | 61 | (declare (optimize (speed 3))) 62 | (cond ((null-pointer-p (result-set self)) 63 | (cons (mysql-affected-rows (pointer self)) nil)) 64 | (t 65 | (result-data self type-map)))) 66 | 67 | (defmethod set-field-names-and-types ((self connection)) 68 | "Retrieve from a MYSQL_RES a list of cons (( )*) " 69 | (let ((mysql-res (result-set self))) 70 | (if (null-pointer-p mysql-res) 71 | (setf (result-set-fields self) 72 | (append (list nil) (result-set-fields self))) 73 | (let* ((num-fields (1- (mysql-num-fields mysql-res))) 74 | (fields (mysql-fetch-fields mysql-res)) 75 | (extracted-fields 76 | (loop for i from 0 to num-fields 77 | collect (let ((mref (mysql-fetch-field mysql-res))) 78 | (list 79 | (foreign-slot-value mref 'mysql-field 'name) 80 | (foreign-enum-keyword 81 | 'enum-field-types 82 | (foreign-slot-value mref 'mysql-field 'type)) 83 | (foreign-slot-value mref 'mysql-field 'flags)))))) 84 | (setf (result-set-fields self) 85 | (append 86 | (list extracted-fields) 87 | (result-set-fields self))))))) 88 | 89 | (defmethod result-data ((self connection) type-map) 90 | "Internal function that processes a result set and returns all the data. 91 | If field-names-and-types is NIL the raw (string) data is returned" 92 | (declare (optimize (speed 3)) 93 | (ftype (function (t t fixnum list (or t null)) list) process-row)) 94 | (let* ((mysql-res (result-set self)) 95 | (num-fields (mysql-num-fields mysql-res))) 96 | (loop for row = (mysql-fetch-row mysql-res) 97 | until (null-pointer-p row) 98 | collect (process-row mysql-res 99 | row 100 | num-fields 101 | (car (result-set-fields self)) 102 | type-map)))) 103 | 104 | (defmethod next-result-set ((self connection) &key dont-release store) 105 | "Position for the the next result set. Returns T if there is a result 106 | set to process and NIL when the last result set has been passed. 107 | 108 | sets. Use this method with (query \"SELECT\" :store NIL). Call 109 | next-result-set to position on the first result set then use next-row 110 | to fetch all the individual rows. 111 | 112 | Use dont-release if you don't want cl-mysql to release all the resources 113 | when the last result set has been processed. This might be useful, for 114 | instance, if you need access to the fields through result-set-fields after 115 | the result set has been processed. 116 | 117 | You can, if you wish elect to not process each individual row of a result 118 | set by setting :store T. However, you cannot then use next-row because 119 | you must process the entire result set in one go. 120 | 121 | 
CL-USER> (query \"SELECT ...\" :store nil)
122 |    CL-USER> (next-result-set *)
123 |    T
124 |    CL-USER> (next-row **)
125 |    ...
126 | " 127 | (let ((last-result (result-set self)) 128 | (affected-rows 0)) 129 | ;; Firstly free any prior results 130 | (unless (null-pointer-p last-result) 131 | (setf affected-rows (mysql-affected-rows (pointer self))) 132 | (mysql-free-result last-result) 133 | (setf (slot-value self 'result-set) (null-pointer))) 134 | ;; Now check if this is not the first result whether there are 135 | ;; more results 136 | (if (and (> (length (result-set-fields self)) 0) 137 | (not (eql 0 (mysql-next-result (pointer self))))) 138 | (progn (unless dont-release 139 | (return-or-close (owner-pool self) self)) 140 | (return-from next-result-set 141 | (values nil affected-rows)))) 142 | ;; Now advance into the next result set. 143 | (let ((result-set (if store 144 | (mysql-store-result (pointer self)) 145 | (mysql-use-result (pointer self))))) 146 | (error-if-null-with-fields self result-set) 147 | (setf (result-set self) result-set) 148 | (values t affected-rows)))) 149 | 150 | (defmethod next-row ((self connection) &key (type-map *type-map*)) 151 | "Retrieve and decode (according to the type map) the next row in the query. This 152 | function will return NIL when the last row has been retrieved." 153 | (unless (null-pointer-p (result-set self)) 154 | (let* ((fields-and-names (car (result-set-fields self))) 155 | (row (mysql-fetch-row (result-set self)))) 156 | (if (null-pointer-p row) 157 | (error-if-set self) 158 | (process-row (result-set self) row 159 | (length fields-and-names) 160 | fields-and-names type-map))))) 161 | 162 | (defmethod connection-equal ((self t) (other t)) 163 | nil) 164 | 165 | (defmethod connection-equal ((self connection) (other connection)) 166 | "Two connections are equal if they point to the same memory location." 167 | (and self other 168 | (pointer-eq (pointer self) (pointer other)))) 169 | 170 | (defmethod connected ((self connection)) 171 | (not (null-pointer-p (pointer self)))) 172 | 173 | (defmethod available ((self connection)) 174 | (and (connected self) (not (in-use self)))) 175 | 176 | (defmethod toggle ((self connection)) 177 | (setf (in-use self) (not (in-use self)))) 178 | 179 | -------------------------------------------------------------------------------- /integration-test.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp -*- 2 | ;;;; $Id: 879d60ee31ee5a7818b968486638a7d3f78c265b $ 3 | ;;;; 4 | ;;;; Copyright (c) 2009 Steve Knight 5 | ;;;; 6 | ;;;; Permission is hereby granted, free of charge, to any person obtaining 7 | ;;;; a copy of this software and associated documentation files (the 8 | ;;;; "Software"), to deal in the Software without restriction, including 9 | ;;;; without limitation the rights to use, copy, modify, merge, publish, 10 | ;;;; distribute, sublicense, and/or sell copies of the Software, and to 11 | ;;;; permit persons to whom the Software is furnished to do so, subject to 12 | ;;;; the following conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 19 | ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 21 | ;;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 22 | ;;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 23 | ;;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 24 | ;;;; 25 | (in-package cl-mysql-test) 26 | 27 | (defparameter *z* 1) 28 | (defparameter *z-mutex* (cl-mysql-system:make-lock nil)) 29 | 30 | (defun reset-z () 31 | (cl-mysql-system:with-lock *z-mutex* 32 | (setf *z* 0))) 33 | 34 | (defun z () 35 | (cl-mysql-system:with-lock *z-mutex* 36 | (incf *z*))) 37 | 38 | (defun getz () 39 | (cl-mysql-system:with-lock *z-mutex* 40 | *z*)) 41 | 42 | (defun setup-test-database (min max) 43 | (reset-z) 44 | (setf (min-connections *conn*) min) 45 | (setf (max-connections *conn*) max) 46 | (query "DROP DATABASE IF EXISTS cl_mysql_test; CREATE DATABASE cl_mysql_test; 47 | GRANT ALL ON cl_mysql_test.* TO USER(); FLUSH PRIVILEGES;" 48 | :database *conn*) 49 | (use "cl_mysql_test" :database *conn*) 50 | (query "CREATE TABLE X ( X INT, T TIMESTAMP DEFAULT CURRENT_TIMESTAMP )" :database *conn*)) 51 | 52 | (defun long-test (n) 53 | "Loop from 1 to" 54 | (let ((last-t (get-universal-time))) 55 | (setup-test-database 1 2) 56 | (cl-mysql-system:wait-on-threads 57 | (loop for i from 1 to n 58 | collect (progn 59 | ;(sleep 0.02) 60 | (if (= 0 (mod (1+ (getz)) 1000)) 61 | (progn 62 | (format t "Processed 1000 entries in: ~Ds" (- 63 | (get-universal-time) 64 | last-t)) 65 | (setf last-t (get-universal-time))) 66 | (princ ".")) 67 | (if (= 0 (mod (getz) 80)) 68 | (format t "~%")) 69 | 70 | (start-thread-in-nsecs 71 | (lambda () 72 | (query 73 | (format nil "USE cl_mysql_test; INSERT INTO X (X) VALUES (~D)" (z)) 74 | :database *conn*)) 0 ;(random 1) 75 | ))))) 76 | (let ((result 77 | (first (nth-row (query "SELECT AVG(X) FROM X" :database *conn*) 0)))) 78 | (format t "~%Database average result = ~D ~[OK~;FAIL~]" result 79 | (if (equalp (/ (+ n 1) 2) result) 0 1))) 80 | t) 81 | -------------------------------------------------------------------------------- /mysql.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp -*- 2 | ;;;; $Id: c0a614db0d712418a37d613a35d22b2c8baa380d $ 3 | ;;;; 4 | ;;;; Copyright (c) 2009 Steve Knight 5 | ;;;; 6 | ;;;; Permission is hereby granted, free of charge, to any person obtaining 7 | ;;;; a copy of this software and associated documentation files (the 8 | ;;;; "Software"), to deal in the Software without restriction, including 9 | ;;;; without limitation the rights to use, copy, modify, merge, publish, 10 | ;;;; distribute, sublicense, and/or sell copies of the Software, and to 11 | ;;;; permit persons to whom the Software is furnished to do so, subject to 12 | ;;;; the following conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 19 | ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 21 | ;;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 22 | ;;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 23 | ;;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 24 | 25 | ;;; Decoders 26 | ;;; 27 | (in-package "CL-MYSQL-SYSTEM") 28 | 29 | (defun string-to-integer (string &optional len) 30 | (declare (optimize (speed 3) (safety 3)) 31 | (type (or null simple-string) string) 32 | (type (or null (integer 0 128)) len)) 33 | (when (and string (> (or len (length string)) 0)) 34 | (parse-integer string :junk-allowed t))) 35 | 36 | (defun string-to-float (string len) 37 | "Convert a MySQL float representation into a double. Note that we could do better on DECIMAL/NUMERICs 38 | that have 0 places after the decimal." 39 | (declare (optimize (speed 3) (safety 3)) 40 | (type fixnum len) 41 | (type (or null simple-string) string)) 42 | (when (and string (> len 0)) 43 | (let ((sign 1) 44 | (integer-part 0) 45 | (decimal-part 0) 46 | (mantissa-part 0) 47 | (decimal-length 1) 48 | (mantissa-sign 1) 49 | (passed-decimal nil) 50 | (passed-mantissa nil)) 51 | (declare (type integer integer-part decimal-part) 52 | (type (integer 0 310) mantissa-part) 53 | (type (integer -1 1) mantissa-sign sign) 54 | (type (or null t) passed-decimal passed-mantissa)) 55 | (loop for c across string 56 | do (cond ((char= c #\+) 57 | (if passed-mantissa 58 | (setf mantissa-sign 1) 59 | (setf sign 1))) 60 | ((char= c #\-) 61 | (if passed-mantissa 62 | (setf mantissa-sign -1) 63 | (setf sign -1))) 64 | ((char= c #\.) 65 | (setf passed-decimal t)) 66 | ((char= c #\e) 67 | (setf passed-mantissa t)) 68 | (passed-mantissa 69 | (setf mantissa-part 70 | (+ (* mantissa-part 10) 71 | (digit-char-p c)))) 72 | (passed-decimal 73 | (setf decimal-part 74 | (+ (* decimal-part 10) 75 | (digit-char-p c)) 76 | decimal-length 77 | (* 10 decimal-length))) 78 | (t 79 | (setf integer-part 80 | (+ (* integer-part 10) 81 | (digit-char-p c)))))) 82 | (coerce (* sign (+ integer-part (/ decimal-part decimal-length)) (expt 10 (* mantissa-sign mantissa-part))) 'double-float)))) 83 | 84 | (defun string-to-ratio (string len) 85 | (when (and string (> (or len (length string)) 0)) 86 | (let ((numerator 0) 87 | (denominator 1) 88 | (passed-decimal nil) 89 | (sign 1)) 90 | (declare (type integer numerator denominator)) 91 | (loop for c across string 92 | do (progn 93 | (cond ((eq c #\.) 94 | (setf passed-decimal t)t) 95 | ((eq c #\-) 96 | (setf sign (* -1 sign))) 97 | (t 98 | (when passed-decimal 99 | (setf denominator (* denominator 10))) 100 | (setf numerator 101 | (+ (digit-char-p c) (* numerator 10))))))) 102 | (* sign (/ numerator denominator))))) 103 | 104 | (defun string-to-date (string &optional len) 105 | (declare (optimize (speed 3) (safety 3)) 106 | (type (or null simple-string) string) 107 | (type (or null fixnum) len)) 108 | (when (and string (> (or len (length string)) 9)) 109 | (let ((y (parse-integer string :start 0 :end 4)) 110 | (m (parse-integer string :start 5 :end 7)) 111 | (d (parse-integer string :start 8 :end 10))) 112 | (unless (or (zerop y) 113 | (zerop m) 114 | (zerop d)) 115 | (encode-universal-time 0 0 0 d m y))))) 116 | 117 | (defun string-to-seconds (string &optional len) 118 | "Fairly ugly function to turn MySQL TIME duration into an integer representation. 119 | It's complicated because of ... well, read this: http://dev.mysql.com/doc/refman/5.0/en/time.html" 120 | (declare (optimize (speed 3) (safety 3)) 121 | (type (or null simple-string) string) 122 | (type (or null fixnum) len)) 123 | (when string 124 | (let* ((strlen (or len (length string))) 125 | (offset (- strlen 8))) 126 | (when (and (>= offset 0) (< offset 3)) 127 | (let* ((start (if (eql #\- (elt string 0)) 1 0)) 128 | (h (parse-integer string :start start :end (+ 2 offset))) 129 | (m (parse-integer string :start (+ 3 offset) :end (+ 5 offset))) 130 | (s (parse-integer string :start (+ 6 offset) :end (+ 8 offset))) 131 | (time (+ (* h 3600) (* m 60) s))) 132 | (declare (type (integer 0 839) h) 133 | (type (integer 0 59) m s)) 134 | (if (eql start 1) 135 | (* -1 time) 136 | time)))))) 137 | 138 | (defun string-to-universal-time (string &optional len) 139 | (declare (optimize (speed 3) (safety 3)) 140 | (type (or null simple-string) string) 141 | (type (or null fixnum) len)) 142 | (cond 143 | ((equal "0000-00-00 00:00:00" string) 144 | nil) 145 | ((and string (> (or len (length string)) 0)) 146 | (+ (string-to-date (subseq string 0 10)) 147 | (string-to-seconds (subseq string 11)))))) 148 | 149 | (eval-when (:load-toplevel) 150 | (mapcar (lambda (map) 151 | (setf (gethash (first map) *type-map*) (second map))) 152 | '((:DECIMAL string-to-ratio) 153 | (:TINY string-to-integer) 154 | (:SHORT string-to-integer) 155 | (:LONG string-to-integer) 156 | (:FLOAT string-to-float) 157 | (:DOUBLE string-to-float) 158 | (:NULL (lambda (string) 159 | (declare (ignore string)) 160 | nil)) 161 | (:TIMESTAMP string-to-universal-time) 162 | (:LONGLONG string-to-integer) 163 | (:INT24 string-to-integer) 164 | (:DATE string-to-date) 165 | (:TIME string-to-seconds) 166 | (:DATETIME string-to-universal-time) 167 | (:YEAR string-to-integer) 168 | (:NEWDATE string-to-universal-time) 169 | (:NEWDECIMAL string-to-ratio)))) 170 | 171 | ;;; Error handling 172 | ;;; 173 | (define-condition mysql-error (error) 174 | ((message :initarg :message :reader mysql-error-message) 175 | (errno :initarg :errno :reader mysql-error-errno)) 176 | (:report (lambda (condition stream) 177 | (format stream "MySQL error: \"~A\" (errno = ~D)." 178 | (mysql-error-message condition) 179 | (mysql-error-errno condition))))) 180 | 181 | (define-condition cl-mysql-error (error) 182 | ((message :initarg :message :reader cl-mysql-error-message)) 183 | (:report (lambda (condition stream) 184 | (format stream "cl-mysql error: \"~A\"" 185 | (cl-mysql-error-message condition))))) 186 | 187 | (defun error-if-non-zero (database return-value) 188 | (let ((error-function (etypecase database (statement #'mysql-stmt-error) 189 | (connection #'mysql-error))) 190 | (errorno-function (etypecase database (statement #'mysql-stmt-errno) 191 | (connection #'mysql-errno)))) 192 | (if (not (eql 0 return-value)) 193 | (error 'mysql-error 194 | :message (funcall error-function (pointer database)) 195 | :errno (funcall errorno-function (pointer database)))) 196 | return-value)) 197 | 198 | (defun error-if-null (database return-value) 199 | (if (null-pointer-p return-value) 200 | (let ((db-handle (typecase database 201 | (integer database) 202 | ; Not quite sure if this is right 203 | ; but it seems to work - RG 204 | (connection (pointer database)) 205 | (t database)))) 206 | (error 'mysql-error 207 | :message (mysql-error db-handle) 208 | :errno (mysql-errno db-handle)))) 209 | return-value) 210 | 211 | (defun error-if-null-with-fields (database return-value) 212 | (if (> (mysql-field-count (pointer database)) 0) 213 | (error-if-null database return-value))) 214 | 215 | (defun error-if-set (database) 216 | (let ((errno (mysql-errno (pointer database)))) 217 | (when (not (eql 0 errno)) 218 | (error 'mysql-error 219 | :message (mysql-error (pointer database)) 220 | :errno errno)))) 221 | 222 | ;;; High level API 223 | ;;; 224 | (defmacro with-connection ((var &optional database (release t)) &body body) 225 | (let ((retval (gensym))) 226 | `(let* ((,var (aquire (or ,database *last-database*) t)) 227 | (,retval ())) 228 | (unwind-protect (setq ,retval (progn ,@body)) 229 | (when ,release 230 | (release ,var))) 231 | ,retval))) 232 | 233 | (defun use (name &key database) 234 | "Equivalent to running: 235 | CL-USER> (query \"USE \")" 236 | (with-connection (conn database) 237 | (error-if-non-zero conn (mysql-select-db (pointer conn) name)) 238 | (values))) 239 | 240 | (defun decode-version (int-version) 241 | "Return a list of version details " 242 | (let* ((version (mod int-version 100)) 243 | (major-version (floor int-version 10000)) 244 | (release-level (mod (floor int-version 100) 10))) 245 | (list major-version release-level version))) 246 | 247 | (defun client-version () 248 | "Returns a three part list containing the decoded client version information" 249 | (decode-version (mysql-get-client-version))) 250 | 251 | (defun server-version (&key database) 252 | "Returns a three part list containing the decoded server version information" 253 | (with-connection (conn database) 254 | (decode-version (mysql-get-server-version (pointer conn))))) 255 | 256 | (defun single-result-set (conn fn &rest args) 257 | "MySQL provides a class of functions that just process a single result set. 258 | Note that we won't explicity free the result set because return-or-close 259 | will do the cleanup for us." 260 | (let ((result (apply fn args))) 261 | (error-if-null conn result) 262 | (setf (result-set conn) result) 263 | (list (cons 264 | (process-result-set conn *type-map*) 265 | (result-set-fields conn))))) 266 | 267 | (defun list-dbs (&key database) 268 | (with-connection (conn database) 269 | (single-result-set conn (lambda () 270 | (mysql-list-dbs (pointer conn) 271 | (null-pointer)))))) 272 | (defun list-tables (&key database) 273 | (with-connection (conn database) 274 | (single-result-set conn (lambda () 275 | (mysql-list-tables (pointer conn) (null-pointer)))))) 276 | 277 | (defun list-fields (table &key database) 278 | (with-connection (conn database) 279 | (single-result-set conn (lambda () 280 | (mysql-list-fields (pointer conn) table (null-pointer)))))) 281 | 282 | (defun list-processes (&key database) 283 | (with-connection (conn database) 284 | (single-result-set conn (lambda () 285 | (mysql-list-processes (pointer conn)))))) 286 | 287 | ;;; String/Character set/Collation stuff 288 | ;;; 289 | (defun escape-string (string &key database) 290 | "Given a string, encode it appropriately. This function relies on the fact that 291 | the character set encoding was set to UTF-8 when the connection is made." 292 | (when string 293 | (with-connection (conn database) 294 | (with-foreign-string (from-string string) 295 | (let* ((from-length (cffi-utf8-length from-string)) 296 | (to-length (1+ (* from-length 2))) 297 | (to-string (foreign-alloc :unsigned-char :count to-length)) 298 | (return-string nil)) 299 | (unwind-protect (progn 300 | (mysql-real-escape-string (pointer conn) to-string from-string from-length) 301 | (setf return-string (foreign-string-to-lisp to-string))) 302 | (foreign-free to-string)) 303 | (values return-string)))))) 304 | 305 | (defun cffi-utf8-length (cffi-string) 306 | "We need this function because mysql_real_escape_string requires the length 307 | of the from string in bytes (not characters)" 308 | (do ((i 0 (incf i))) 309 | ((eql 0 (mem-ref cffi-string :unsigned-char i)) i))) 310 | 311 | (defun get-character-set-info (&key database) 312 | "Returns the character set information for the connection as a sequence: 313 | (collation name number state)" 314 | (with-connection (conn database) 315 | (with-foreign-object (charset 'character-set) 316 | (mysql-get-character-set-info (pointer conn) charset) 317 | (list (foreign-slot-value charset 'character-set 'csname) 318 | (foreign-slot-value charset 'character-set 'name) 319 | (foreign-slot-value charset 'character-set 'number) 320 | (foreign-slot-value charset 'character-set 'state))))) 321 | 322 | (defun set-character-set (csname &key database) 323 | (with-connection (conn database) 324 | (error-if-non-zero conn (mysql-set-character-set (pointer conn) csname)))) 325 | 326 | ;;; Result set functions 327 | ;;; 328 | 329 | (defparameter *binary-types* #(:BIT :BINARY :VARBINARY :GEOMETRY)) 330 | (declaim (inline extract-field process-row)) 331 | (defun extract-field (row field-index field-length type-map field-detail) 332 | "Returns either a string or an unsigned byte array for known binary types. The 333 | designation of binary types per the C API seems a bit weird. Basically, 334 | BIT, BINARY and VARBINARY are binary and so are BLOBs with the binary flag 335 | set. It seems that other fields also have the binary flag set that are not 336 | binary and the BIT type, whilst binary doesn't have the flag set. Bizarre-o." 337 | (destructuring-bind (field-name field-type field-flag) field-detail 338 | (declare (ignore field-name) 339 | (optimize (speed 3) (safety 3)) 340 | (type (integer 0 65536) field-index field-flag) 341 | (type (integer 0 4294967296) field-length ) 342 | (type (simple-array symbol) *binary-types*)) 343 | (if (eql field-length 0) 344 | (return-from extract-field nil)) 345 | (if (or (and (eq field-type :BLOB) 346 | (logtest +field-binary+ field-flag)) 347 | (find field-type *binary-types*)) 348 | (let ((arr (make-array field-length :element-type '(unsigned-byte 8))) 349 | (ptr (mem-ref row :pointer field-index))) 350 | (loop for i from 0 to (1- field-length) 351 | do (setf (elt arr i) (mem-ref ptr :unsigned-char i))) 352 | (values arr)) 353 | (let ((fn (gethash field-type type-map))) 354 | (declare (type (or null symbol function) fn)) 355 | (values (if fn 356 | (funcall fn (mem-ref row :string field-index) field-length) 357 | (mem-ref row :string field-index))))))) 358 | 359 | (defun process-row (mysql-res row num-fields field-names-and-types type-map) 360 | (declare (optimize (speed 3) (safety 3)) 361 | (type (integer 0 65536) num-fields)) 362 | (let* ((mysql-lens (mysql-fetch-lengths mysql-res)) 363 | (int-size (foreign-type-size :pointer))) 364 | (declare (type (integer 0 16) int-size)) 365 | (loop for i of-type fixnum from 0 to (* num-fields int-size) by int-size 366 | for f of-type list in field-names-and-types 367 | collect (extract-field row i 368 | (mem-aref mysql-lens :unsigned-long (/ i int-size)) type-map f)))) 369 | 370 | 371 | 372 | (defun query (query &key (type-map *type-map*) database (store t)) 373 | "For a SELECT query or stored procedure that returns data, query will return 374 | a list of result sets. Each result set will have 1 or more sublists 375 | where the first sublist contains the column names and the remaining lists 376 | represent the rows of the result set. If the query does not return a result 377 | set (for example if the query is an INSERT, UPDATE) the return value is the 378 | number of rows affected. Because cl-mysql supports multiple-statements 379 | you can execute code like the following: 380 | 381 | 
CL-MYSQL-SYSTEM> (query \"CREATE TABLE a(a INT); 
382 |                   INSERT INTO a (a) VALUES (1); DELETE FROM a; DROP TABLE a\")
383 |    ((0) (1) (1) (0))
384 | 385 | The type-map, if set will alter the decoding into CL types. If you set 386 | this to nil it will have the effect of disabling all CL type conversions 387 | and return either character or binary data only. 388 | 389 | This might be useful for performance reasons, (cl-mysql 390 | is much faster when it doesn't need to translate types) but it also might 391 | be all you need. Consider for instance if you're displaying a lot of 392 | numerics on a web-page. If you do not need to convert the data into 393 | floats/integers before displaying them on a page then raw could be useful 394 | here too. cl-mysql attempts to convert all numeric types to their closest 395 | CL representation. For very large numerics, or numerics that have very 396 | high precision this might not be what you want. In this case you could 397 | attempt to write your own conversion routine and inject it into cl-mysql 398 | through the type-map. 399 | 400 | The currented supported conversions are as follows (MySQL type -> CL type): 401 | 402 |
  • DECIMAL/NUMERIC -> RATIO
    • 403 |
  • INT/TINYINT/SMALLINT/MEDIUMINT/BIGINT/YEAR -> INTEGER
    • 404 |
  • FLOAT/REAL/DOUBLE PRECISION -> DOUBLE-FLOAT
    • 405 |
  • DATE/DATETIME/TIMESTAMP -> INTEGER (Universal time)
    • 406 |
  • TIME -> INTEGER (Seconds)
    • 407 |
  • CHAR/VARCHAR/TEXT/TINYTEXT/MEDIUMTEXT/LONGTEXT -> STRING
    • 408 |
  • BIT/BLOB/MEDIUMBLOB/LONGBLOB/TINYBLOB/GEOMETRY -> SIMPLE-ARRAY '(UNSIGNED-BYTE 8 )
    • 409 |
410 | 411 | If :store is T query returns a list of result sets. Each result set is a 412 | list with the first element set to the data and the second elements set to 413 | the column data. Since this structure can be a little awkward to handle 414 | you can use nth-row to manipulate the structure more sanely. 415 | 416 | If :store is NIL query returns the allocated connection object. You should 417 | use next-result-set and next-row to step through the results." 418 | (with-connection (conn database store) 419 | (error-if-non-zero conn (mysql-query (pointer conn) query)) 420 | (cond (store 421 | (loop 422 | while (next-result-set conn :store t :dont-release t) 423 | nconc (list (list (process-result-set conn 424 | (or type-map (make-hash-table))) 425 | (car (result-set-fields conn)))))) 426 | (t 427 | (setf (use-query-active conn) t) 428 | (values conn))))) 429 | 430 | (defun ping (&key database) 431 | "Check whether a connection is established or not. If :opt-reconnect is 432 | set and there is no connection then MySQL's C API attempts a reconnection." 433 | (with-connection (conn database) 434 | (error-if-non-zero conn (mysql-ping (pointer conn))) 435 | (values t))) 436 | 437 | (defun %set-string-option (option value &key database) 438 | (let ((retval 0)) 439 | (with-connection (conn database) 440 | (with-foreign-pointer-as-string (str 255) 441 | (setf retval (mysql-options (pointer conn) 442 | (foreign-enum-value 'enum-options option) 443 | (lisp-string-to-foreign value str 255))))) 444 | (values retval))) 445 | 446 | (defun %set-int-option (option value &key database) 447 | (let ((retval 0)) 448 | (with-connection (conn database) 449 | (with-foreign-object (int-value :int) 450 | (setf (mem-ref int-value :int) value) 451 | (setf retval (mysql-options (pointer conn) 452 | (foreign-enum-value 'enum-options option) 453 | int-value)))) 454 | (values retval))) 455 | 456 | (defun option (option value &key database) 457 | "Use this to set a client specific connection option. 458 | CL-USER> (option :opt-reconnect 1)" 459 | (typecase value 460 | (string (%set-string-option option value :database database)) 461 | (null (%set-int-option option 0 :database database)) 462 | (t (%set-int-option option value :database database)))) 463 | 464 | (defun get-field (column-name field-names-and-types row) 465 | "Returns the correct element in the sequence from the row that matches the column-name" 466 | (elt row (position column-name field-names-and-types :test 'string= :key 'car))) 467 | 468 | (defun force-kill () 469 | "Internal convenience function to clean up connections" 470 | (connect) 471 | (query (with-output-to-string (s) 472 | (loop for f in (car (list-processes)) do 473 | (format s "KILL ~D;" (car f)))))) 474 | 475 | ;;; Convenience functions for accessing results 476 | 477 | (defun nth-row (result-set-list n &optional nth-result-set) 478 | "Return the nth-row of the nth-result set." 479 | (let ((row (nth n (first (nth (or nth-result-set 0) 480 | result-set-list))))) 481 | (typecase row 482 | (number row) 483 | (t row)))) 484 | 485 | (defmacro with-rows ((var-row query-string 486 | &key 487 | (var-result (gensym)) 488 | (database '*last-database*) 489 | (type-map '*type-map*)) 490 | &body body) 491 | "Takes a query-string and iterates over the result sets assigning 492 | var-row to each individual row. If you supply var-result it will 493 | hold the result set sequence number. This macro generates code 494 | that does not store the complete result so should be suitable for 495 | working with very large data sets." 496 | `(let ((connection (query ,query-string 497 | :type-map ,type-map 498 | :database ,database 499 | :store nil)) 500 | (,var-result 0)) 501 | (loop while (next-result-set connection) 502 | do (progn 503 | (loop for ,var-row = (next-row connection :type-map ,type-map) 504 | until (null,var-row) 505 | do (progn ,@body)) 506 | (incf ,var-result))))) 507 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp -*- 2 | ;;;; $Id: 2ebd7c237f2511eda741173a49d6062c4c1c0c50 $ 3 | ;;;; 4 | ;;;; Copyright (c) 2009 Steve Knight 5 | ;;;; 6 | ;;;; Permission is hereby granted, free of charge, to any person obtaining 7 | ;;;; a copy of this software and associated documentation files (the 8 | ;;;; "Software"), to deal in the Software without restriction, including 9 | ;;;; without limitation the rights to use, copy, modify, merge, publish, 10 | ;;;; distribute, sublicense, and/or sell copies of the Software, and to 11 | ;;;; permit persons to whom the Software is furnished to do so, subject to 12 | ;;;; the following conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 19 | ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 21 | ;;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 22 | ;;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 23 | ;;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 24 | ;;;; 25 | (defpackage com.hackinghat.cl-mysql 26 | (:use :cl) 27 | (:nicknames "CL-MYSQL") 28 | (:shadowing-import-from "CL-MYSQL-SYSTEM" 29 | #:connect #:query #:use #:disconnect #:ping #:option 30 | #:client-version #:server-version 31 | #:list-dbs #:list-tables #:list-processes #:list-fields 32 | #:escape-string #:next-result-set #:next-row #:*type-map* 33 | #:nth-row #:with-rows #:result-set-fields #:process-result-set 34 | #:opt-connect-timeout #:opt-compress #:opt-named-pipe 35 | #:init-command #:read-default-file #:read-default-group 36 | #:+client-compress+ #:+client-found-rows+ #:+client-ignore-sigpipe+ 37 | #:+client-ignore-space+ #:+client-interactive+ #:+client-local-files+ 38 | #:+client-multi-statements+ #:+client-multi-results+ #:+client-no-schema+ 39 | #:+client-ssl+ #:+client-remember-options+ 40 | #:set-charset-dir #:set-charset-name #:opt-local-infile 41 | #:opt-protocol #:shared-memory-base-name #:opt-read-timeout 42 | #:opt-write-timeout #:opt-use-result 43 | #:opt-use-remote-connection #:opt-use-embedded-connection 44 | #:opt-guess-connection #:set-client-ip #:secure-auth 45 | #:report-data-truncation #:opt-reconnect 46 | #:opt-ssl-verify-server-cert) 47 | (:export #:connect #:query #:use #:disconnect #:ping #:option 48 | #:client-version #:server-version 49 | #:list-dbs #:list-tables #:list-processes #:list-fields 50 | #:escape-string #:next-result-set #:next-row #:*type-map* 51 | #:nth-row #:with-rows #:result-set-fields #:process-result-set 52 | #:+client-compress+ #:+client-found-rows+ #:+client-ignore-sigpipe+ 53 | #:+client-ignore-space+ #:+client-interactive+ #:+client-local-files+ 54 | #:+client-multi-statements+ #:+client-multi-results+ #:+client-no-schema+ 55 | #:+client-ssl+ #:+client-remember-options+ 56 | #:opt-connect-timeout #:opt-compress #:opt-named-pipe 57 | #:init-command #:read-default-file #:read-default-group 58 | #:set-charset-dir #:set-charset-name #:opt-local-infile 59 | #:opt-protocol #:shared-memory-base-name #:opt-read-timeout 60 | #:opt-write-timeout #:opt-use-result 61 | #:opt-use-remote-connection #:opt-use-embedded-connection 62 | #:opt-guess-connection #:set-client-ip #:secure-auth 63 | #:report-data-truncation #:opt-reconnect 64 | #:opt-ssl-verify-server-cert)) 65 | 66 | -------------------------------------------------------------------------------- /package.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash -x 2 | 3 | PWD=`pwd` 4 | DIR=`basename ${PWD}` 5 | RELEASE_VERSION=0.2.1 6 | 7 | cd .. 8 | ln -sf ${DIR} ${DIR}_${RELEASE_VERSION} 9 | tar -cvzf ${DIR}_${RELEASE_VERSION}.tar.gz ${DIR}_${RELEASE_VERSION}/*.asd ${DIR}_${RELEASE_VERSION}/*.lisp 10 | gpg -b -a ${DIR}_${RELEASE_VERSION}.tar.gz 11 | #scp ${DIR}_${RELEASE_VERSION}.tar.gz* stkni@shuttle:/data/apache/hackinghat.com/releases 12 | cp ${DIR}_${RELEASE_VERSION}.tar.gz* /mnt/hgfs/Temp 13 | #scp -P 21 ${DIR}_${RELEASE_VERSION}.tar.gz* stkni@hackinghat.com:/data/apache/hackinghat.com/releases 14 | rm ${DIR}_${RELEASE_VERSION}.tar.gz* 15 | rm ${DIR}_${RELEASE_VERSION} 16 | cd - 17 | -------------------------------------------------------------------------------- /pool.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp -*- 2 | ;;;; $Id: df44ccd2590a1c6a1f128bcd512cabd262b671c6 $ 3 | ;;;; 4 | ;;;; Copyright (c) 2009 Steve Knight 5 | ;;;; 6 | ;;;; Permission is hereby granted, free of charge, to any person obtaining 7 | ;;;; a copy of this software and associated documentation files (the 8 | ;;;; "Software"), to deal in the Software without restriction, including 9 | ;;;; without limitation the rights to use, copy, modify, merge, publish, 10 | ;;;; distribute, sublicense, and/or sell copies of the Software, and to 11 | ;;;; permit persons to whom the Software is furnished to do so, subject to 12 | ;;;; the following conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 19 | ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 21 | ;;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 22 | ;;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 23 | ;;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 24 | ;;;; 25 | (in-package "CL-MYSQL-SYSTEM") 26 | 27 | (defparameter *last-database* nil 28 | "The last allocated connection-pool. Note that this special is a default 29 | argument to a lot of the higher level API functions.") 30 | 31 | (defparameter *debug* t) 32 | 33 | (defclass connection-pool (connectable) 34 | ((ssl-ca :reader ssl-ca :initarg :ssl-ca :initform nil) 35 | (hostname :reader hostname :initarg :hostname :initform nil) 36 | (username :reader username :initarg :username :initform nil) 37 | (password :reader password :initarg :password :initform nil) 38 | (database :reader database :initarg :database :initform nil) 39 | (port :reader port :initarg :port :initform 0) 40 | (socket :reader socket :initarg :socket :initform nil) 41 | (flags :reader flags :initarg :flags :initform 0) 42 | (min-connections :reader min-connections :initarg :min-connections :initform 1) 43 | (max-connections :reader max-connections :initarg :max-connections :initform 1) 44 | (available-connections :type (or array null) :accessor available-connections :initform nil) 45 | (connections :type (or array null) :accessor connections :initform nil) 46 | ;; We need two locks per pool, one to keep the internal state of the pool 47 | ;; safe and another to allow us to block other threads from trying to aquire more 48 | ;; connections than the pool contains ... 49 | (pool-lock :accessor pool-lock :initform (make-lock "Pool Lock")) 50 | (wait-queue-lock :accessor wait-queue-lock :initform (make-lock "Queue Lock")) 51 | (wait-queue :accessor wait-queue :initform (make-wait-resource))) 52 | (:documentation "All connections are initiated through a pool. ")) 53 | 54 | (defmethod (setf max-connections) ((max-connect number) (pool connection-pool)) 55 | "Change the maximum number of connections available in the pool. Note 56 | that you can change this value whilst the pool is waiting for a connection 57 | to become available." 58 | (with-lock (pool-lock pool) 59 | (setf (slot-value pool 'max-connections) max-connect)) 60 | (pool-notify pool)) 61 | 62 | (defmethod (setf min-connections) ((min-connect number) (pool connection-pool)) 63 | "Change the minimum number of connections available in the pool. Note 64 | that you can change this value whilst the pool is waiting for a connection 65 | to become available." 66 | (with-lock (pool-lock pool) 67 | (setf (slot-value pool 'min-connections) min-connect)) 68 | (pool-notify pool)) 69 | 70 | (defmethod add-connection ((self connection-pool) (conn connection)) 71 | "Add a connection into the pool." 72 | (vector-push-extend conn (connections self)) 73 | (vector-push-extend conn (available-connections self)) 74 | (pool-notify self)) 75 | 76 | (defmethod remove-connection-from-array ((self connection-pool) array conn) 77 | "Returns a new array with the given connection object removed (set to NIL) 78 | The pool should be locked before this method is called." 79 | (unless (null conn) 80 | (map-into array 81 | (lambda (x) 82 | (if (connection-equal conn x) 83 | nil 84 | x)) 85 | array)) 86 | (clean-connections self array)) 87 | 88 | (defmethod connect-to-server ((self connection-pool)) 89 | "Create a new single connection and add it to the pool." 90 | (let ((mysql (mysql-init (null-pointer)))) 91 | (when (ssl-ca self) 92 | (mysql-ssl-set mysql (null-pointer) 93 | (null-pointer) 94 | (ssl-ca self) 95 | (null-pointer) 96 | (null-pointer))) 97 | (let ((connection (mysql-real-connect mysql 98 | (or (hostname self) "localhost") 99 | (or (username self) (null-pointer)) 100 | (or (password self) (null-pointer)) 101 | (or (database self) (null-pointer)) 102 | (or (port self) 0) 103 | (or (socket self) (null-pointer)) 104 | (flags self)))) 105 | (error-if-null mysql connection) 106 | (add-connection self (make-instance 'connection 107 | :pointer connection 108 | :owner-pool self 109 | :in-use nil))))) 110 | 111 | (defmethod disconnect-from-server ((self connection) conn) 112 | (disconnect-from-server (owner-pool self) (or conn self))) 113 | 114 | (defmethod disconnect-from-server ((self connection-pool) (conn connection)) 115 | "Internal method. Pool should be locked before-hand. " 116 | (remove-connection-from-array self (available-connections self) conn) 117 | (remove-connection-from-array self (connections self) conn) 118 | (mysql-close (pointer conn))) 119 | 120 | (defmethod count-connections ((self connection-pool)) 121 | "Count the number of connections in the pool. If you are dynamically 122 | changing the size of the pool after it is created this number could be 123 | greater or less than max/min connections. Set :available-only if you 124 | only want to know how many connections are currently ready to use." 125 | ;; Mutex 126 | (values 127 | (count-if #'identity (connections self)) 128 | (count-if #'identity (available-connections self)))) 129 | 130 | (defmethod can-aquire ((self connection-pool)) 131 | "Returns true if a call to aquire would result in a connection being allocated" 132 | (multiple-value-bind (total available) 133 | (count-connections self) 134 | (or (> available 0) (< total (max-connections self))))) 135 | 136 | (defmethod can-aquire-lock ((self connection-pool)) 137 | (with-lock (pool-lock self) 138 | (can-aquire self))) 139 | 140 | (defmethod connect-upto-minimum ((self connection-pool) n min) 141 | "We use this method to allocate up to the minimum number of connections. 142 | It is called once after initialize-instance and will be called again every 143 | time a connection is acquired from the pool." 144 | ;; Mutex 145 | (loop for i from 0 to (1- (- min n)) 146 | do (connect-to-server self))) 147 | 148 | (defmethod initialize-instance :after ((self connection-pool) &rest initargs) 149 | "The connection arrays need to be set-up after the pool is created." 150 | (declare (ignore initargs)) 151 | (setf (connections self) (make-array (max-connections self) 152 | :fill-pointer 0 153 | :adjustable t)) 154 | (setf (available-connections self) (make-array 155 | (max-connections self) 156 | :fill-pointer 0 157 | :adjustable t)) 158 | (connect-upto-minimum self 0 (min-connections self))) 159 | 160 | 161 | (defmethod take-first ((self connection-pool)) 162 | "Take the first available connection from the pool. If there are none, 163 | NIL is returned." 164 | (with-lock (pool-lock self) 165 | ;; If we can't aquire a connection return nil 166 | (if (not (can-aquire self)) 167 | (return-from take-first nil)) 168 | 169 | ;; We can aquire but it might be because the max-number of connections 170 | ;; has changed so connect up to the minimum required to service this 171 | ;; request. 172 | (multiple-value-bind (total available) (count-connections self) 173 | (connect-upto-minimum self total 174 | (if (> available 0) 175 | (min-connections self) 176 | (min 177 | (max-connections self) 178 | (1+ total))))) 179 | ;; There now must be a connection available in the pool, so find the 180 | ;; first one and lock it. 181 | (let ((first (loop for conn across (connections self) 182 | if (and conn (available conn)) 183 | return conn))) 184 | (toggle first) 185 | (remove-connection-from-array self (available-connections self) first) 186 | (clean-connections self (available-connections self)) 187 | (values first)))) 188 | 189 | (defmethod aquire ((self t) (block t)) 190 | (error 'cl-mysql-error :message "There is no available pool to aquire from!")) 191 | 192 | (defmethod aquire ((self connection-pool) (block t)) 193 | "Aquire from the pool a single connection object that can be passed to higher 194 | level API functions like QUERY. 195 | 196 | On implementations that support threading this method will block if :block 197 | is T, and available connections is 0 and there are already max-connections. 198 | On implementations that do not support threading this method will always 199 | return NIL." 200 | (let ((candidate (take-first self))) 201 | (if (not candidate) 202 | (if block 203 | (loop until candidate 204 | do (progn 205 | ;; The exact behaviour of pool-wait is implementation 206 | ;; dependent. Some implementations will sleep some 207 | ;; will wait on a condition variable. 208 | (pool-wait self) 209 | (setf candidate (take-first self)))) 210 | (error 'cl-mysql-error :message "Can't allocate any more connections!"))) 211 | (values candidate))) 212 | 213 | (defmethod aquire ((self connection) block) 214 | (declare (ignore block)) 215 | (unless (in-use self) 216 | ;; Block on in-use? 217 | self)) 218 | 219 | (defmethod contains ((self connection-pool) array conn) 220 | (loop for c across array 221 | if (connection-equal c conn) 222 | return t)) 223 | 224 | (defmethod return-to-available ((self connection) &optional conn) 225 | (declare (ignore conn)) 226 | ;; Deal with the pool 227 | (return-to-available (owner-pool self) self) 228 | ;; Now clean up any stateful data that could be hanging around 229 | (setf (result-set self) (null-pointer) 230 | (result-set-fields self) nil 231 | (in-use self) nil)) 232 | 233 | (defmethod return-to-available ((self connection-pool) &optional conn) 234 | "If the connection is not in the expected state raise an error." 235 | (if (or (not (in-use conn)) 236 | (contains self (available-connections self) conn)) 237 | (error 'cl-mysql-error :message 238 | "Inconsistent state! Connection is not currently in use.")) 239 | (vector-push-extend conn (available-connections self))) 240 | 241 | (defmethod clean-connections ((self connection-pool) array) 242 | "Housekeeping to remove null connections from the end of the connections 243 | array. Pool should be locked." 244 | (setf (fill-pointer array) 245 | (do ((i (1- (fill-pointer array)) (decf i))) 246 | ((or (< i 0) (elt array i)) (1+ i))))) 247 | 248 | (defmethod consume-unused-results ((self connection)) 249 | "If a client attempts to release a connection without consuming all the 250 | results then we take care of that for them. Because we are probably 251 | being called from release don't also auto-release when we reach the 252 | last result!" 253 | (loop while (next-result-set self :dont-release t))) 254 | 255 | (defmethod return-or-close ((self connection-pool) (conn connection)) 256 | "Given a pool and a connection, close it if there are more than 257 | min-connections or return it to the pool if we have less than or equal 258 | to min-connections" 259 | 260 | ;; These don't strictly need to be locked because we make no guarantees 261 | ;; about the thread safety of a single connection 262 | (unless (null-pointer-p (result-set conn)) 263 | (mysql-free-result (result-set conn))) 264 | (setf (slot-value conn 'result-set) (null-pointer)) 265 | (setf (result-set-fields conn) nil) 266 | (setf (use-query-active conn) nil) 267 | (with-lock (pool-lock self) 268 | (let ((total (count-connections self))) 269 | (if (> total (min-connections self)) 270 | (disconnect-from-server self conn) 271 | (return-to-available conn)) 272 | (clean-connections self (connections self)) 273 | (clean-connections self (available-connections self)))) 274 | (pool-notify self)) 275 | 276 | 277 | (defmethod release ((self connection) &optional conn) 278 | "Convenience method to allow the release to be done with a connection" 279 | (release (owner-pool self) (or conn self))) 280 | 281 | (defmethod release ((self connection-pool) &optional conn) 282 | "Release a connection back into the pool." 283 | (if (null conn) 284 | (error 'cl-mysql-error :message "Internal Error: Connection must be supplied when releasing a pool object!")) 285 | (if (use-query-active conn) 286 | (consume-unused-results conn)) 287 | (return-or-close self conn) 288 | (values)) 289 | 290 | (defun connect (&key host user password database port socket ssl-ca 291 | (client-flag (list +client-compress+ 292 | +client-multi-statements+ 293 | +client-multi-results+)) 294 | (min-connections 1) (max-connections 1)) 295 | "Connect will present to MySQL sensible defaults for all the connection items. 296 | The following code will attach you to a MySQL instance running on localhost, 297 | as the current user with no password. It will automatically turn on 298 | compression between client-and-server and also enable multiple-result sets 299 | if possible. 300 | 301 | 
CL-USER> (connect)
302 | 303 | If unsuccesful connect will raise a CL-MYSQL-ERROR, otherwise it will place 304 | the connection into a pool, note that all connections are pool-able, 305 | a single connection is simply the special case of a pool with only one 306 | connection. 307 | 308 | The pool has two slots, min-connections and max-connections. There will 309 | always be min-connections available in the pool. If you are using all 310 | min-connections and max-connections is greater than min-connections, 311 | the pool will continue to allocate connections until max-connections are 312 | used. After this an attempt to aquire more connections from the pool 313 | should block (if your implementation supports it). When a connection is 314 | released (this is done automatically unless you explicity disable it) the 315 | connection to the server is closed if we have allocated more connections 316 | than min-connections. 317 | 318 | The last allocated pool object is placed into a special variable 319 | *last-database* which is defaulted from the higher level API functions." 320 | (setf *last-database* (make-instance 'connection-pool 321 | :ssl-ca ssl-ca 322 | :hostname host 323 | :username user 324 | :password password 325 | :database database 326 | :port port 327 | :socket socket 328 | :flags (reduce #'logior client-flag) 329 | :min-connections min-connections 330 | :max-connections max-connections))) 331 | 332 | (defun disconnect (&optional (database *last-database*)) 333 | "This method will disconnect all the connections in the pool. Note 334 | that if you attempt to use the pool again after calling this method 335 | it will re-allocate upto min-connections before servicing your request." 336 | (disconnect-all database)) 337 | 338 | (defmethod disconnect-all ((self connection-pool)) 339 | "Disconnects all the connections in the pool from the database." 340 | (let ((array (subseq (connections self) 0))) 341 | (loop for conn across array 342 | do (disconnect-from-server self conn)))) 343 | -------------------------------------------------------------------------------- /prepare.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp -*- 2 | ;;;; $Id: d2bc98da0d22af7b666c0426e415cbc0be525b63 $ 3 | ;;;; 4 | ;;;; Copyright (c) 2009 Steve Knight 5 | ;;;; 6 | ;;;; Permission is hereby granted, free of charge, to any person obtaining 7 | ;;;; a copy of this software and associated documentation files (the 8 | ;;;; "Software"), to deal in the Software without restriction, including 9 | ;;;; without limitation the rights to use, copy, modify, merge, publish, 10 | ;;;; distribute, sublicense, and/or sell copies of the Software, and to 11 | ;;;; permit persons to whom the Software is furnished to do so, subject to 12 | ;;;; the following conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 19 | ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 21 | ;;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 22 | ;;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 23 | ;;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 24 | 25 | (in-package "CL-MYSQL-SYSTEM") 26 | 27 | (defparameter *default-sequence-length* 1024 28 | "This is the maximum length that a sequence sent as a bound parameter can be 29 | It's a bit lame really. How it should really work is that 'bind' gives you 30 | a binding and re-binds (if that's possible) when the buffer is too small. 31 | 32 | In practice, though, I doubt it matters very much.") 33 | 34 | 35 | (defclass statement () 36 | ((pointer :reader pointer :initarg :pointer :initform (cffi:null-pointer)) 37 | (database :reader database :initarg :database :initform nil) 38 | (nargs :accessor nargs :initarg :nargs :initform nil) 39 | (args :accessor args :initarg :args :initform (cffi:null-pointer)) 40 | (bound-map :accessor bound-map :initarg :bound-map :initform nil) 41 | (fully-bound :accessor fully-bound :initform nil)) 42 | (:documentation "A holder for a MYSQL_STMT structure")) 43 | 44 | (defmethod bind-arg ((self statement) index) 45 | (if (> index (1- (nargs self))) 46 | (error 'cl-mysql-error 47 | :message (format nil "Index: ~D is out of range on this statement." index))) 48 | (cffi:mem-aref (args self) 'mysql-bind index)) 49 | 50 | (defmethod configure-bindings ((self statement) nargs) 51 | "Sets up a statement object ready to receive nargs bindings" 52 | (setf 53 | (slot-value self 'nargs) 54 | nargs 55 | (slot-value self 'args) 56 | (cffi:foreign-alloc 'mysql-bind :count nargs) 57 | (slot-value self 'bound-map) 58 | (make-array nargs :initial-element nil))) 59 | 60 | (defun prepare (query &key (database *last-database*)) 61 | "Prepare a query and return a statement object. Use execute to access it" 62 | (with-connection (conn database) 63 | (let ((stmt (mysql-stmt-init (pointer conn)))) 64 | (error-if-null conn stmt) 65 | (let ((stmt-object (make-instance 'statement 66 | :pointer stmt 67 | :database database))) 68 | (error-if-non-zero stmt-object 69 | (mysql-stmt-prepare stmt query (length query))) 70 | (configure-bindings stmt-object (param-count stmt-object)) 71 | (values stmt-object))))) 72 | 73 | (defmethod sqlstate ((self statement)) 74 | "Returns the ANSI / ODBC SQL status" 75 | (mysql-stmt-sqlstate (pointer self))) 76 | 77 | (defmethod param-count ((self statement)) 78 | "The number of required parameters that must be bound to this statement." 79 | (mysql-stmt-param-count (pointer self))) 80 | 81 | (defparameter *stmt-ctype-map* (make-hash-table)) 82 | 83 | (eval-when (:load-toplevel) 84 | (mapcar (lambda (map) 85 | (setf (gethash (first map) *stmt-ctype-map*) (second map))) 86 | '((:TINY :char) 87 | (:SMALLINT :int) 88 | (:INT :long) 89 | (:LONG :long) 90 | (:BIGINT :longlong) 91 | (:STRING :string) 92 | (:FLOAT :float) 93 | (:DOUBLE :double)))) 94 | 95 | (defmethod next-index ((self statement)) 96 | "Returns the next unbound index or throws an error if there isn't one. This 97 | is just a convenience method to allow bind to be called on a simple list of types: 98 | CL-USER> mapcar (lambda (x) (bind a-statement x)) (:LONG :STRING :FLOAT))" 99 | (loop for i from 0 to (nargs self) 100 | for x across (bound-map self) 101 | if (null x) do (return-from next-index i)) 102 | (error 'cl-mysql-error :message "All the parameters on this query are bound")) 103 | 104 | (defmethod release-binding ((self statement) index) 105 | "Deallocates the memory that we attached to this binding." 106 | (when (bound-parameter-p self index) 107 | (let ((arg (bind-arg self index))) 108 | (dolist (slot '(buffer is-null length error)) 109 | (foreign-free (foreign-slot-value arg 'mysql-bind slot)))))) 110 | 111 | (defmethod close-statement ((self statement)) 112 | "Close a statement and free all the allocated memory." 113 | (error-if-non-zero self (mysql-stmt-close (pointer self))) 114 | (dotimes (i (nargs self)) 115 | (release-binding self i)) 116 | (foreign-free (args self))) 117 | 118 | (defun repeat-char (s n) 119 | (cond ((= n 0) nil) 120 | (t (concatenate 'string s (repeat-char s (1- n)))))) 121 | 122 | (defmethod bind ((self statement) sql-type &optional supplied-index (max-len *default-sequence-length*)) 123 | "Set up the bind structure for later use" 124 | (let ((index (or supplied-index (next-index self)))) 125 | (if (> index (1- (nargs self))) 126 | (error 'cl-mysql-error 127 | :message (format nil "Index: ~D is out of range on this statement." index))) 128 | ;; TODO: Later, when we are able to bind on the fly this should only release if the 129 | ;; buffer type has changed. 130 | (release-binding self index) 131 | (let ((arg (bind-arg self index)) 132 | (c-type (gethash sql-type *stmt-ctype-map*))) 133 | (setf (foreign-slot-value arg 'mysql-bind 'buffer) 134 | (cond ((eq :string c-type) 135 | (foreign-alloc :char :count max-len)) 136 | (t (foreign-alloc c-type)))) 137 | 138 | (setf 139 | (foreign-slot-value arg 'mysql-bind 'buffer-type) 140 | (foreign-enum-value 'enum-field-types sql-type) 141 | 142 | (foreign-slot-value arg 'mysql-bind 'length) 143 | (foreign-alloc :int) 144 | 145 | (foreign-slot-value arg 'mysql-bind 'is-null) 146 | (foreign-alloc :char) 147 | 148 | (foreign-slot-value arg 'mysql-bind 'error) 149 | (foreign-alloc :char) 150 | 151 | ;; Mark this argument as bound 152 | (elt (bound-map self) index) t) 153 | ;; If all elements are now bound we assume we can dispatch 154 | ;; the arguments to the server 155 | (if (and (not (cffi:null-pointer-p (pointer self))) 156 | (notany #'null (bound-map self))) 157 | (error-if-non-zero self 158 | (mysql-stmt-bind-param 159 | (pointer self) 160 | (args self))))))) 161 | 162 | (defmethod bound-unbound-to-string ((self statement)) 163 | "If the user didn't bind all the arguments bind those unbound ones now." 164 | (loop for i from 0 to (nargs self) 165 | for b across (bound-map self) 166 | do (if (not b) 167 | (bind self :string i)))) 168 | 169 | (defmethod bound-parameter-p ((self statement) index) 170 | "Returns T if the argument at index is bound." 171 | (elt (bound-map self) index)) 172 | 173 | (defmethod assign-bound-argument ((self statement) index value) 174 | "Take the supplied argument and try to bind it" 175 | 176 | (let* ((arg (bind-arg self index)) 177 | (buffer-type (foreign-enum-keyword 'enum-field-types 178 | (foreign-slot-value arg 'mysql-bind 'buffer-type))) 179 | (buffer-c-type (gethash buffer-type *stmt-ctype-map*)) 180 | (type-adjusted-value (typecase value 181 | (string (format nil "~A" value)) 182 | (t value))) 183 | (is-null (if value 0 1)) 184 | (length (typecase value 185 | (string (length type-adjusted-value)) 186 | (t 0)))) 187 | (if (eq :string buffer-c-type) 188 | (lisp-string-to-foreign type-adjusted-value 189 | (foreign-slot-value arg 'mysql-bind 'buffer) 190 | *default-sequence-length*) 191 | (setf (mem-ref (foreign-slot-value arg 'mysql-bind 'buffer) 192 | buffer-c-type) type-adjusted-value)) 193 | 194 | (setf (mem-ref (foreign-slot-value arg 'mysql-bind 'is-null) :char) 195 | is-null 196 | (mem-ref (foreign-slot-value arg 'mysql-bind 'length) :int) 197 | (cffi-utf8-length (foreign-slot-value arg 'mysql-bind 'buffer)) 198 | (foreign-slot-value arg 'mysql-bind 'buffer-length) 199 | (cffi-utf8-length (foreign-slot-value arg 'mysql-bind 'buffer))))) 200 | 201 | (defmethod execute ((self statement) &rest args) 202 | (let ((nsupplied-args (length args)) 203 | (nstatement-args (nargs self))) 204 | (if (not (eql nsupplied-args nstatement-args)) 205 | (error 'cl-mysql-error 206 | :message (format nil "You need to specify ~D arguments, not ~D." nstatement-args nsupplied-args))) 207 | ;; Lazily bind the remaining arguments to string 208 | (if (not (fully-bound self)) 209 | (bound-unbound-to-string self)) 210 | ;; Assign the supplied arguments to the statement 211 | (loop for i from 0 to nstatement-args 212 | for arg in args 213 | do (assign-bound-argument self i arg)) 214 | (error-if-non-zero self 215 | (mysql-stmt-execute (pointer self))) 216 | (mysql-stmt-affected-rows (pointer self)))) -------------------------------------------------------------------------------- /system.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp -*- 2 | ;;;; $Id: e487b20fcc8037d82ba2713ce29c24df23bdf100 $ 3 | ;;;; 4 | ;;;; Copyright (c) 2009 Steve Knight 5 | ;;;; 6 | ;;;; Permission is hereby granted, free of charge, to any person obtaining 7 | ;;;; a copy of this software and associated documentation files (the 8 | ;;;; "Software"), to deal in the Software without restriction, including 9 | ;;;; without limitation the rights to use, copy, modify, merge, publish, 10 | ;;;; distribute, sublicense, and/or sell copies of the Software, and to 11 | ;;;; permit persons to whom the Software is furnished to do so, subject to 12 | ;;;; the following conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 19 | ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 21 | ;;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 22 | ;;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 23 | ;;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 24 | ;;;; 25 | (defpackage com.hackinghat.cl-mysql-system 26 | (:use :cl :cffi) 27 | (:nicknames "CL-MYSQL-SYSTEM") 28 | (:export 29 | ;; Conditions 30 | #:cl-mysql-error #:mysql-error 31 | ;; Classes 32 | #:connection #:connection-pool #:statement 33 | ;; Methods 34 | #:connected #:available #:in-use #:pointer #:connection-equal 35 | #:aquire #:can-aquire #:release #:count-connections #:contains #:connections 36 | #:available-connections #:result-set #:max-connections #:min-connections 37 | #:result-set-fields #:process-result-set #:pool-lock #:bind-arg 38 | #:configure-bindings #:bound-map #:next-index #:bind #:close 39 | ;; Special vairalbes 40 | #:*type-map* #:*last-database* 41 | ;; Public functions 42 | #:connect #:query #:use #:disconnect #:ping #:option 43 | #:client-version #:server-version 44 | #:list-dbs #:list-tables #:list-processes #:list-fields 45 | #:escape-string 46 | #:next-result-set #:next-row #:nth-row #:with-rows 47 | ;; Thread functions 48 | #:wait-on-threads #:make-lock #:with-lock #:start-thread-in-nsecs 49 | ;; Constants 50 | #:+client-compress+ #:+client-found-rows+ #:+client-ignore-sigpipe+ 51 | #:+client-ignore-space+ #:+client-interactive+ #:+client-local-files+ 52 | #:+client-multi-statements+ #:+client-multi-results+ #:+client-no-schema+ 53 | #:+client-ssl+ #:+client-remember-options+ 54 | ;; Internal functions 55 | #:string-to-integer #:string-to-float 56 | #:string-to-date #:string-to-seconds #:string-to-universal-time 57 | #:string-to-ratio #:extract-field #:cffi-utf8-length 58 | ;; Enum Options 59 | #:opt-connect-timeout #:opt-compress #:opt-named-pipe 60 | #:init-command #:read-default-file #:read-default-group 61 | #:set-charset-dir #:set-charset-name #:opt-local-infile 62 | #:opt-protocol #:shared-memory-base-name #:opt-read-timeout 63 | #:opt-write-timeout #:opt-use-result 64 | #:opt-use-remote-connection #:opt-use-embedded-connection 65 | #:opt-guess-connection #:set-client-ip #:secure-auth 66 | #:report-data-truncation #:opt-reconnect 67 | #:opt-ssl-verify-server-cert)) 68 | 69 | (in-package "CL-MYSQL-SYSTEM") 70 | 71 | (define-foreign-library libmysqlclient 72 | (:darwin (:or "libmysqlclient.20.dylib" "libmysqlclient.dylib")) 73 | ((:not :windows) (:or (:default "libmysqlclient_r") (:default "libmysqlclient"))) 74 | (:windows (:default "libmysql"))) 75 | 76 | (use-foreign-library libmysqlclient) 77 | 78 | ;;; Client options 79 | ;;; 80 | (defconstant +client-compress+ 32) 81 | (defconstant +client-found-rows+ 2) 82 | (defconstant +client-ignore-sigpipe+ 4096) 83 | (defconstant +client-ignore-space+ 256) 84 | (defconstant +client-interactive+ 1024) 85 | (defconstant +client-local-files+ 128) 86 | (defconstant +client-multi-statements+ (ash 1 16)) 87 | (defconstant +client-multi-results+ (ash 1 17)) 88 | (defconstant +client-no-schema+ 16) 89 | (defconstant +client-ssl+ (ash 1 11)) 90 | (defconstant +client-remember-options+ (ash 1 31)) 91 | 92 | ;;; Field flags 93 | ;;; 94 | (defconstant +field-not-null+ 1 95 | "Field can't be null") 96 | (defconstant +field-primary-key+ 2 97 | "Field is part of a primary key") 98 | (defconstant +field-unique-key+ 4 99 | "Field is part of a unique key") 100 | (defconstant +field-multiple-key+ 8 101 | "Field is part of a key") 102 | (defconstant +field-blob+ 16 103 | "Field is a blob") 104 | (defconstant +field-unsigned+ 32 105 | "Field is unsigned") 106 | (defconstant +field-zerofill+ 64 107 | "Field is zerofill") 108 | (defconstant +field-binary+ 128 109 | "Field is binary") 110 | (defconstant +field-enum+ 256 111 | "Field is an enum") 112 | (defconstant +field-auto-increment+ 512 113 | "Field is auto increment") 114 | (defconstant +field-timestamp+ 1024 115 | "Field is a timestamp") 116 | (defconstant +field-set+ 2048 117 | "Field is a set") 118 | (defconstant +field-no-default+ 4096 119 | "Field doesn't have a default value") 120 | (defconstant +field-num+ 32768 121 | "Field is num") 122 | 123 | ;;; Error codes 124 | ;;; 125 | (defconstant +error-first+ 2000) 126 | (defconstant +unknown-error+ 2000) 127 | (defconstant +socket-create-error+ 2001) 128 | (defconstant +connection-error+ 2002) 129 | (defconstant +conn-host-error+ 2003) 130 | (defconstant +ipsock-error+ 2004) 131 | (defconstant +unknown-host+ 2005) 132 | (defconstant +server-gone-error+ 2006) 133 | (defconstant +version-error+ 2007) 134 | (defconstant +out-of-memory+ 2008) 135 | (defconstant +wrong-host-info+ 2009) 136 | (defconstant +localhost-connection+ 2010) 137 | (defconstant +tcp-connection+ 2011) 138 | (defconstant +server-handshake-err+ 2012) 139 | (defconstant +server-lost+ 2013) 140 | (defconstant +commands-out-of-sync+ 2014) 141 | (defconstant +namedpipe-connection+ 2015) 142 | (defconstant +namedpipewait-error+ 2016) 143 | (defconstant +namedpipeopen-error+ 2017) 144 | (defconstant +namedpipesetstate-error+ 2018) 145 | (defconstant +cant-read-charset+ 2019) 146 | (defconstant +net-packet-too-large+ 2020) 147 | (defconstant +embedded-connection+ 2021) 148 | (defconstant +probe-slave-status+ 2022) 149 | (defconstant +probe-slave-hosts+ 2023) 150 | (defconstant +probe-slave-connect+ 2024) 151 | (defconstant +probe-master-connect+ 2025) 152 | (defconstant +ssl-connection-error+ 2026) 153 | (defconstant +malformed-packet+ 2027) 154 | (defconstant +wrong-license+ 2028) 155 | (defconstant +null-pointer+ 2029) 156 | (defconstant +no-prepare-stmt+ 2030) 157 | (defconstant +params-not-bound+ 2031) 158 | (defconstant +data-truncated+ 2032) 159 | (defconstant +no-parameters-exists+ 2033) 160 | (defconstant +invalid-parameter-no+ 2034) 161 | (defconstant +invalid-buffer-use+ 2035) 162 | (defconstant +unsupported-param-type+ 2036) 163 | (defconstant +shared-memory-connection+ 2037) 164 | (defconstant +shared-memory-connect-request-error+ 2038) 165 | (defconstant +shared-memory-connect-answer-error+ 2039) 166 | (defconstant +shared-memory-connect-file-map-error+ 2040) 167 | (defconstant +shared-memory-connect-map-error+ 2041) 168 | (defconstant +shared-memory-file-map-error+ 2042) 169 | (defconstant +shared-memory-map-error+ 2043) 170 | (defconstant +shared-memory-event-error+ 2044) 171 | (defconstant +shared-memory-connect-abandoned-error+ 2045) 172 | (defconstant +shared-memory-connect-set-error+ 2046) 173 | (defconstant +conn-unknow-protocol+ 2047) 174 | (defconstant +invalid-conn-handle+ 2048) 175 | (defconstant +secure-auth+ 2049) 176 | (defconstant +fetch-canceled+ 2050) 177 | (defconstant +no-data+ 2051) 178 | (defconstant +no-stmt-metadata+ 2052) 179 | (defconstant +no-result-set+ 2053) 180 | (defconstant +not-implemented+ 2054) 181 | (defconstant +server-lost-extended+ 2055) 182 | 183 | (eval-when (:compile-toplevel) 184 | (defparameter *generate-alt-fns* nil 185 | "Compile the library with this value equal to T to get the indirection 186 | facility. For more performance (because there is no wrapper around 187 | the CFFI wrapper!) set this value to NIL") 188 | (defparameter *mysql-dev-api-url* "http://dev.mysql.com/doc/refman/5.0/en/~A.html" 189 | "MySQL uses a standard page naming convention that matches our function names!")) 190 | 191 | (defmacro defmysqlfun ((name internal-name) return-type &body args) 192 | "Takes a mysql function name as a string and registers the 193 | appropriate CFFI function as internal-name. 194 | 195 | If *generate-alt-fns* is T internal-name that denotes T a wrapper function 196 | that sits around the function lib. 197 | 198 | This function will call the lib, unless there is an 'alt-fn 199 | property set on the function's symbol. If such a function exists it is called 200 | instead. 201 | 202 | e.g. 203 | CL-USER> (connect) 204 | CL-USER> (setf (get 'mysql-close 'alt-fn) (lambda (db) 205 | (print \"Closing! \") 206 | (libmysql-close db))) 207 | CL-USER> (disconnect) 208 | Closing!" 209 | (let* ((n name) 210 | (int-name internal-name) 211 | (int-libname (intern (string-upcase 212 | (format nil "lib~A" int-name)))) 213 | (docstring (format nil "Library wrapper for MySQL function: ~A" name)) 214 | (mysql-doc-ref (format nil *mysql-dev-api-url* (string-downcase int-name))) 215 | (arg-names (mapcar #'car args))) 216 | (if *generate-alt-fns* 217 | `(progn (defcfun (,n ,int-libname) ,return-type 218 | ,mysql-doc-ref 219 | ,@args) 220 | (defun ,int-name ,arg-names 221 | ,docstring 222 | (let ((alt-fn (get ',int-name 'alt-fn))) 223 | (if alt-fn 224 | (funcall alt-fn ,@arg-names) 225 | (,int-libname ,@arg-names))))) 226 | `(defcfun (,n ,int-name) ,return-type 227 | ,mysql-doc-ref 228 | ,@args)))) 229 | 230 | (defmysqlfun ("mysql_ssl_set" mysql-ssl-set) :int 231 | (mysql :pointer) 232 | (key :string) 233 | (cert :string) 234 | (ca :string) 235 | (cpath :string) 236 | (cipher :string)) 237 | 238 | (defmysqlfun ("mysql_init" mysql-init) :pointer 239 | (mysql :pointer)) 240 | 241 | (defmysqlfun ("mysql_close" mysql-close) :pointer 242 | (mysql :pointer)) 243 | 244 | (defmysqlfun ("mysql_error" mysql-error) :string 245 | (mysql :pointer)) 246 | 247 | (defmysqlfun ("mysql_errno" mysql-errno) :unsigned-int 248 | (mysql :pointer)) 249 | 250 | (defmysqlfun ("mysql_real_connect" mysql-real-connect) :pointer 251 | (mysql :pointer) 252 | (host :string) 253 | (user :string) 254 | (password :string) 255 | (database :string) 256 | (port :int) 257 | (unix-socket :string) 258 | (client-flag :unsigned-long)) 259 | 260 | (defmysqlfun ("mysql_affected_rows" mysql-affected-rows) :unsigned-long 261 | (mysql :pointer)) 262 | 263 | (defmysqlfun ("mysql_character_set_name" mysql-character-set-name) :string 264 | (mysql :pointer)) 265 | 266 | (defmysqlfun ("mysql_ping" mysql-ping) :int 267 | (mysql :pointer)) 268 | 269 | (defmysqlfun ("mysql_query" mysql-query) :int 270 | (mysql :pointer) 271 | (statement :string)) 272 | 273 | (defmysqlfun ("mysql_real_escape_string" mysql-real-escape-string) :unsigned-long 274 | (mysql :pointer) 275 | (to :string) 276 | (from :string) 277 | (length :unsigned-int)) 278 | 279 | (defmysqlfun ("mysql_escape_string" mysql-escape-string) :unsigned-long 280 | (to :string) 281 | (from :string) 282 | (length :unsigned-int)) 283 | 284 | (defmysqlfun ("mysql_field_count" mysql-field-count) :unsigned-int 285 | (mysql :pointer)) 286 | 287 | (defmysqlfun ("mysql_get_client_version" mysql-get-client-version) :unsigned-long) 288 | 289 | (defmysqlfun ("mysql_get_character_set_info" mysql-get-character-set-info) :void 290 | (mysql :pointer) 291 | (cs :pointer)) 292 | 293 | (defmysqlfun ("mysql_set_character_set" mysql-set-character-set) :int 294 | (mysql :pointer) 295 | (csname :string)) 296 | 297 | (defmysqlfun ("mysql_get_server_version" mysql-get-server-version) :unsigned-long 298 | (mysql :pointer)) 299 | 300 | (defmysqlfun ("mysql_select_db" mysql-select-db) :int 301 | (mysql :pointer) 302 | (db :string)) 303 | 304 | (defmysqlfun ("mysql_store_result" mysql-store-result) :pointer 305 | (mysql :pointer)) 306 | 307 | (defmysqlfun ("mysql_use_result" mysql-use-result) :pointer 308 | (mysql :pointer)) 309 | 310 | (defmysqlfun ("mysql_num_rows" mysql-num-rows) :unsigned-long 311 | (mysql-res :pointer)) 312 | 313 | (defmysqlfun ("mysql_list_dbs" mysql-list-dbs) :pointer 314 | (mysql :pointer) 315 | (wild :string)) 316 | 317 | (defmysqlfun ("mysql_list_tables" mysql-list-tables) :pointer 318 | (mysql :pointer) 319 | (wild :string)) 320 | 321 | (defmysqlfun ("mysql_list_fields" mysql-list-fields) :pointer 322 | (mysql :pointer) 323 | (table :string) 324 | (wild :string)) 325 | 326 | (defmysqlfun ("mysql_list_processes" mysql-list-processes) :pointer 327 | (mysql :pointer)) 328 | 329 | (defmysqlfun ("mysql_fetch_row" mysql-fetch-row) :pointer 330 | (mysql-res :pointer)) 331 | 332 | (defmysqlfun ("mysql_free_result" mysql-free-result) :void 333 | (mysql-res :pointer)) 334 | 335 | (defmysqlfun ("mysql_fetch_lengths" mysql-fetch-lengths) :pointer 336 | (mysql-res :pointer)) 337 | 338 | (defmysqlfun ("mysql_num_fields" mysql-num-fields) :unsigned-int 339 | (mysql-res :pointer)) 340 | 341 | (defmysqlfun ("mysql_next_result" mysql-next-result) :int 342 | (mysql :pointer)) 343 | 344 | (defmysqlfun ("mysql_fetch_fields" mysql-fetch-fields) :pointer 345 | (mysql-res :pointer)) 346 | 347 | (defmysqlfun ("mysql_fetch_field" mysql-fetch-field) :pointer 348 | (mysql-res :pointer)) 349 | 350 | (defmysqlfun ("mysql_options" mysql-options) :int 351 | (mysql :pointer) 352 | (option :int) 353 | (arg :pointer)) 354 | 355 | ;; NULL if error 356 | (defmysqlfun ("mysql_stmt_init" mysql-stmt-init) :pointer 357 | (mysql :pointer)) 358 | 359 | ;; Non-zero if error 360 | (defmysqlfun ("mysql_stmt_prepare" mysql-stmt-prepare) :int 361 | (stmt :pointer) 362 | (stmt_str :string) 363 | (length :unsigned-long)) 364 | 365 | ;; Non-zero if error 366 | (defmysqlfun ("mysql_stmt_bind_param" mysql-stmt-bind-param) :char 367 | (stmt :pointer) 368 | (bind :pointer)) 369 | 370 | (defmysqlfun ("mysql_stmt_sqlstate" mysql-stmt-sqlstate) :string 371 | (stmt :pointer)) 372 | 373 | (defmysqlfun ("mysql_stmt_errno" mysql-stmt-errno) :int 374 | (stmt :pointer)) 375 | 376 | (defmysqlfun ("mysql_stmt_error" mysql-stmt-error) :string 377 | (stmt :pointer)) 378 | 379 | (defmysqlfun ("mysql_stmt_execute" mysql-stmt-execute) :int 380 | (stmt :pointer)) 381 | 382 | (defmysqlfun ("mysql_stmt_affected_rows" mysql-stmt-affected-rows) :unsigned-long 383 | (stmt :pointer)) 384 | 385 | (defmysqlfun ("mysql_stmt_param_count" mysql-stmt-param-count) :int 386 | (stmt :pointer)) 387 | 388 | (defmysqlfun ("mysql_stmt_close" mysql-stmt-close) :char 389 | (stmt :pointer)) 390 | 391 | (defcenum enum-field-types 392 | :decimal :tiny :short :long :float :double :null :timestamp :longlong 393 | :int24 :date :time :datetime :year :newdate :varchar :bit 394 | (:unknown 63) 395 | (:newdecimal 246) 396 | (:enum 247) 397 | (:set 248) 398 | (:tiny-blob 249) 399 | (:medium-blob 250) 400 | (:long-blob 251) 401 | (:blob 252) 402 | (:var-string 253) 403 | (:string 254) 404 | (:geometry 255)) 405 | 406 | (defcenum enum-options 407 | :opt-connect-timeout :opt-compress :opt-named-pipe 408 | :init-command :read-default-file :read-default-group 409 | :set-charset-dir :set-charset-name :opt-local-infile 410 | :opt-protocol :shared-memory-base-name :opt-read-timeout 411 | :opt-write-timeout :opt-use-result 412 | :opt-use-remote-connection :opt-use-embedded-connection 413 | :opt-guess-connection :set-client-ip :secure-auth 414 | :report-data-truncation :opt-reconnect 415 | :opt-ssl-verify-server-cert) 416 | 417 | (defcstruct mysql-field 418 | (name :string) 419 | (org-name :string) 420 | (table :string) 421 | (org-table :string) 422 | (db :string) 423 | (catalog :string) 424 | (def :string) 425 | (length :unsigned-long) 426 | (max-length :unsigned-long) 427 | (name-length :unsigned-int) 428 | (org-name-length :unsigned-int) 429 | (table-length :unsigned-int) 430 | (org-table-length :unsigned-int) 431 | (db-length :unsigned-int) 432 | (catalog-length :unsigned-int) 433 | (def-length :unsigned-int) 434 | (flags :unsigned-int) 435 | (decimals :unsigned-int) 436 | (charsetnr :unsigned-int) 437 | (type :int)) 438 | 439 | (defcstruct character-set 440 | (number :unsigned-int) 441 | (state :unsigned-int) 442 | (csname :string) 443 | (name :string) 444 | (comment :string) 445 | (dir :string) 446 | (mbminlen :unsigned-int) 447 | (mbmaxlen :unsigned-int)) 448 | 449 | 450 | ;; 5.1 451 | ;;(defcstruct mysql-bind 452 | ;; (length :pointer) 453 | ;; (is-null :pointer) 454 | ;; (buffer :pointer) 455 | ;; (error :pointer) 456 | ;; (row-ptr :pointer) 457 | ;; (store-param-func :pointer) 458 | ;; (fetch-result-func :pointer) 459 | ;; (skip-result-func :pointer) 460 | ;; (buffer-length :unsigned-long) 461 | ;; (offset :unsigned-long) 462 | ;; (length-value :unsigned-long) 463 | ;; (param-number :unsigned-int) 464 | ;; (pack-length :unsigned-int) 465 | ;; (buffer-type :int) 466 | ;; (error-value :char) 467 | ;; (is-unsigned :char) 468 | ;; (long-data-used :char) 469 | ;; (is-null-value :char) 470 | ;; (extension :pointer)) 471 | 472 | ;; 5.0 473 | (defcstruct mysql-bind 474 | (length :pointer) 475 | (is-null :pointer) 476 | (buffer :pointer) 477 | (error :pointer) 478 | (buffer-type :int) 479 | (buffer-length :unsigned-long) 480 | (row-ptr :pointer) 481 | (offset :unsigned-long) 482 | (length-value :unsigned-long) 483 | (param-number :unsigned-int) 484 | (pack-length :unsigned-int) 485 | (error-value :char) 486 | (is-unsigned :char) 487 | (long-data-used :char) 488 | (is-null-value :char) 489 | (store-param-func :pointer) 490 | (fetch-result-func :pointer) 491 | (skip-result-func :pointer)) 492 | -------------------------------------------------------------------------------- /test-pool.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp -*- 2 | ;;;; $Id: 68106b3ae0888959c4e9768f3028d8e133205239 $ 3 | ;;;; 4 | ;;;; Copyright (c) 2009 Steve Knight 5 | ;;;; 6 | ;;;; Permission is hereby granted, free of charge, to any person obtaining 7 | ;;;; a copy of this software and associated documentation files (the 8 | ;;;; "Software"), to deal in the Software without restriction, including 9 | ;;;; without limitation the rights to use, copy, modify, merge, publish, 10 | ;;;; distribute, sublicense, and/or sell copies of the Software, and to 11 | ;;;; permit persons to whom the Software is furnished to do so, subject to 12 | ;;;; the following conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 19 | ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 21 | ;;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 22 | ;;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 23 | ;;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 24 | ;;;; 25 | (in-package "CL-MYSQL-TEST") 26 | 27 | (defvar *conn* nil) 28 | 29 | (defsuite* test-pool) 30 | 31 | (deftest test-connection () 32 | (let ((test-conn (make-instance 'connection :pointer (cffi:make-pointer 1) :in-use t))) 33 | ;; Test an in-use connection 34 | (is (not (available test-conn))) 35 | (is (connected test-conn)) 36 | ;; Now make it available 37 | (setf (in-use test-conn) nil) 38 | (is (available test-conn)) 39 | (is (connected test-conn)) 40 | ;; Now 'disconnect' the connection 41 | (setf (pointer test-conn) (cffi:null-pointer)) 42 | (is (not (connected test-conn))) 43 | (is (not (available test-conn))) 44 | ;; Finally test an invalid connection does something sensible 45 | (setf (in-use test-conn) t) 46 | (is (not (connected test-conn))) 47 | (is (not (available test-conn))))) 48 | 49 | (deftest test-connection-equal () 50 | (is (not (connection-equal 51 | (make-instance 'connection :pointer (cffi:null-pointer)) 52 | nil))) 53 | (is (not (connection-equal 54 | nil 55 | (make-instance 'connection :pointer (cffi:null-pointer))))) 56 | (is (connection-equal 57 | (make-instance 'connection :pointer (cffi:null-pointer)) 58 | (make-instance 'connection :pointer (cffi:null-pointer)))) 59 | (is (not (connection-equal 60 | (make-instance 'connection :pointer (cffi:make-pointer 1)) 61 | (make-instance 'connection :pointer (cffi:null-pointer)))))) 62 | 63 | (deftest test-aquire-connection () 64 | (is (null (aquire (make-instance 'connection :in-use t) nil))) 65 | (is (aquire (make-instance 'connection :in-use nil) nil)) 66 | (is (handler-case (progn (aquire nil nil) nil) 67 | (cl-mysql-error (c) t) 68 | (error (c) nil)))) 69 | 70 | (deftest test-count-connections-directly () 71 | "There will, from time-to-time be NILs in the arrays so we better make sure 72 | that we can handle them and they don't interfere with the count" 73 | (let ((pool (connect :host *host* :user *user* :password *password* 74 | :min-connections 1 :max-connections 1))) 75 | (setf (available-connections pool) 76 | (make-array 3 :fill-pointer t :initial-contents (list NIL (aref (available-connections pool) 0) NIL))) 77 | (setf (connections pool) 78 | (make-array 3 :fill-pointer t :initial-contents (list NIL (aref (connections pool) 0) NIL))) 79 | (is (eql 1 (count-connections pool))) 80 | ;; Now set the number of available to the empty vector, this simulates us 81 | ;; not having any available connections. 82 | (setf (available-connections pool) 83 | (make-array 0)) 84 | (is (eql 1 (count-connections pool))))) 85 | 86 | (deftest test-count-connections () 87 | (let ((pool (connect :host *host* :user *user* :password *password* 88 | :min-connections 1 :max-connections 1))) 89 | (multiple-value-bind (total available) (count-connections pool) 90 | (is (eql 1 total)) 91 | (is (eql 1 available))) 92 | (let ((c (aquire pool nil))) 93 | (multiple-value-bind (total available) (count-connections pool) 94 | (is (eql 1 total)) 95 | (is (eql 0 available))) 96 | (release c) 97 | (multiple-value-bind (total available) (count-connections pool) 98 | (is (eql 1 total)) 99 | (is (eql 1 available)))))) 100 | 101 | (deftest test-pool-expand-contract () 102 | (let ((pool (connect :host *host* :user *user* :password *password* 103 | :min-connections 1 :max-connections 3))) 104 | (multiple-value-bind (total available) (count-connections pool) 105 | (is (eql 1 total)) 106 | (is (eql 1 available))) 107 | (let ((a (query "USE mysql" :store nil)) 108 | (b (query "USE mysql" :store nil))) 109 | (multiple-value-bind (total available) (count-connections pool) 110 | (is (eql 2 total)) 111 | (is (eql 0 available))) 112 | (let ((c (query "USE mysql" :store nil))) 113 | (multiple-value-bind (total available) (count-connections pool) 114 | (is (eql 3 total)) 115 | (is (eql 0 available))) 116 | ;; We need to resurrect this test when allow non-blocking waits .. 117 | ;(is (handler-case (progn (query "USE mysql" :store nil) nil) 118 | ; (cl-mysql-error (co) t) 119 | ; (error (co) nil))) 120 | (release c)) 121 | (multiple-value-bind (total available) (count-connections pool) 122 | (is (eql 2 total)) 123 | (is (eql 0 available))) 124 | (release b) 125 | (release a) 126 | (multiple-value-bind (total available) (count-connections pool) 127 | (is (eql 1 total)) 128 | (is (eql 1 available)))))) 129 | 130 | (deftest test-can-aquire () 131 | (let* ((pool (connect :host *host* :user *user* :password *password* 132 | :min-connections 1 :max-connections 1)) 133 | (conn (query "USE mysql" :store nil))) 134 | (is (not (can-aquire pool))) 135 | (release conn) 136 | (is (can-aquire pool)))) 137 | 138 | (deftest test-contains () 139 | (let* ((pool (connect :host *host* :user *user* :password *password* 140 | :min-connections 1 :max-connections 1)) 141 | (conn (aquire pool nil))) 142 | (is (not (contains pool (available-connections pool) conn))) 143 | (is (contains pool (connections pool) conn)) 144 | (release conn) 145 | (is (contains pool (available-connections pool) conn)) 146 | (is (contains pool (connections pool) conn)))) 147 | 148 | 149 | 150 | #+thread-support 151 | (deftest test-thread-1 () 152 | "Testing threading is always a bit suspect but we can test a little bit of it to 153 | make sure we have the general idea correct." 154 | (let ((pool (connect :host *host* :user *user* :password *password* 155 | :min-connections 1 :max-connections 1)) 156 | (conn (query "SELECT 1" :store nil))) 157 | ;; Now we have a pool of 1 connection that is allocated, so start a thread 158 | ;; that will in 2 seconds increas the pool size to 2. 159 | (start-thread-in-nsecs (lambda () 160 | (setf (max-connections pool) 2)) 1) 161 | ;; This line will block until the thread above changes the max pool size 162 | (list-processes :database pool) 163 | (release conn) 164 | ;; Because we increased the max connection count we should have closed 165 | ;; the extra connection we opened so we should be back to the initial state. 166 | (multiple-value-bind (total available) 167 | (count-connections pool) 168 | (is (eql 1 total)) 169 | (is (eql 1 available))))) 170 | 171 | #+thread-support 172 | (deftest test-thread-2 () 173 | "This is the reverse of test-thread-1 in as much as we have a long running 174 | query and our main thread waits until the long running query is completed. 175 | We use a closure to set a flag to indicate success." 176 | (let ((pool (connect :host *host* :user *user* :password *password* 177 | :min-connections 1 :max-connections 1)) 178 | (result nil)) 179 | ;; Now we have a pool of 1 connection that is allocated, so start a thread 180 | ;; that will in 2 seconds increas the pool size to 2. 181 | (start-thread-in-nsecs (lambda () 182 | (let ((conn (query "SELECT 1" :store nil :database pool))) 183 | (sleep 1) 184 | (setf result 1) 185 | (release conn))) 0 ) 186 | (sleep 0.5) 187 | ;; This line will block until the thread above completes 188 | (list-processes :database pool) 189 | (is (eql 1 result)) 190 | ;; Because we increased the max connection count we should have closed 191 | ;; the extra connection we opened so we should be back to the initial state. 192 | (multiple-value-bind (total available) 193 | (count-connections pool) 194 | (is (eql 1 total)) 195 | (is (eql 1 available))))) 196 | 197 | #+thread-support 198 | (deftest test-thread-3 () 199 | "The killer thread test. Start 100 threads to run in the next 1-3 seconds 200 | that will insert the numbers from 1 to 100 into a table. Join the threads 201 | and then run a query to verify that all was well. This should demonstrate 202 | whether we have a problem with locking or not." 203 | (setf *conn* (or *conn* (connect :host *host* :user *user* :password *password* 204 | :min-connections 1 :max-connections 1))) 205 | (query "DROP DATABASE IF EXISTS cl_mysql_test; CREATE DATABASE cl_mysql_test; 206 | GRANT ALL ON cl_mysql_test.* TO USER(); FLUSH PRIVILEGES;" :database *conn*) 207 | (use "cl_mysql_test" :database *conn*) 208 | (query "CREATE TABLE X ( X INT )" :database *conn*) 209 | (let ((threads (loop for i from 1 to 50 210 | collect (start-thread-in-nsecs 211 | (lambda () 212 | (query 213 | (format nil "USE cl_mysql_test; INSERT INTO X VALUES (~D)" i) 214 | :database *conn*)) 215 | (1+ (random 2)))))) 216 | (cl-mysql-system:wait-on-threads threads) 217 | (is (eql 50 (caaaar (query "SELECT COUNT(*) FROM X" :database *conn*)))))) 218 | -------------------------------------------------------------------------------- /test-prepare.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp -*- 2 | ;;;; $Id: bcc1e9b95693a7007615c63811aa3ffeec2c3af8 $ 3 | ;;;; 4 | ;;;; Copyright (c) 2009 Steve Knight 5 | ;;;; 6 | ;;;; Permission is hereby granted, free of charge, to any person obtaining 7 | ;;;; a copy of this software and associated documentation files (the 8 | ;;;; "Software"), to deal in the Software without restriction, including 9 | ;;;; without limitation the rights to use, copy, modify, merge, publish, 10 | ;;;; distribute, sublicense, and/or sell copies of the Software, and to 11 | ;;;; permit persons to whom the Software is furnished to do so, subject to 12 | ;;;; the following conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 19 | ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 21 | ;;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 22 | ;;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 23 | ;;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 24 | ;;;; 25 | (in-package "CL-MYSQL-TEST") 26 | 27 | (defsuite* test-prepare) 28 | 29 | (deftest test-bind-out-of-range () 30 | (let ((dummy-statement (make-instance 'statement 31 | :nargs 1))) 32 | (is (handler-case (progn 33 | (bind-arg dummy-statement 1) 34 | nil) 35 | (cl-mysql-error () t))))) 36 | 37 | (deftest test-configure-bindings () 38 | (let ((dummy-statement (make-instance 'statement 39 | :nargs 1))) 40 | (configure-bindings dummy-statement 10) 41 | (is 10 (length (bound-map dummy-statement))) 42 | (is (notany #'identity (bound-map dummy-statement))))) 43 | 44 | 45 | (deftest test-next-index-and-bind () 46 | (let ((dummy-statement (make-instance 'statement))) 47 | (configure-bindings dummy-statement 1) 48 | (is 0 (next-index dummy-statement)) 49 | (bind dummy-statement :LONG) 50 | (is (handler-case (progn 51 | (next-index dummy-statement) 52 | nil) 53 | (cl-mysql-error () t))))) 54 | -------------------------------------------------------------------------------- /test.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp -*- 2 | ;;;; $Id: cff72b55cd7f36a5a74c1c23fd9d1b020122629f $ 3 | ;;;; 4 | ;;;; Copyright (c) 2009 Steve Knight 5 | ;;;; 6 | ;;;; Permission is hereby granted, free of charge, to any person obtaining 7 | ;;;; a copy of this software and associated documentation files (the 8 | ;;;; "Software"), to deal in the Software without restriction, including 9 | ;;;; without limitation the rights to use, copy, modify, merge, publish, 10 | ;;;; distribute, sublicense, and/or sell copies of the Software, and to 11 | ;;;; permit persons to whom the Software is furnished to do so, subject to 12 | ;;;; the following conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 19 | ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 21 | ;;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 22 | ;;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 23 | ;;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 24 | ;;;; 25 | (defpackage com.hackinghat.cl-mysql-test 26 | (:nicknames "CL-MYSQL-TEST") 27 | (:use :cl :stefil :cl-mysql-system) 28 | (:export *host* *user* *password*)) 29 | 30 | (in-package "CL-MYSQL-TEST") 31 | 32 | (in-root-suite) 33 | 34 | (defparameter *host* "localhost") 35 | (defparameter *user* nil) 36 | (defparameter *password* nil) 37 | 38 | (defsuite* test) 39 | 40 | (defsuite* test-base) 41 | 42 | (deftest test-string-to-integer () 43 | (is (eq nil (string-to-integer "" 0))) 44 | (is (eq nil (string-to-integer nil 0))) 45 | (is (eql 12345678 (string-to-integer "12345678" 1))) 46 | (is (eql 12345678 (string-to-integer "12345678.0" 1))) 47 | (is (eql 123 (string-to-integer "123x" 1)))) 48 | 49 | (deftest test-string-to-float () 50 | (is (eq nil (string-to-float "" 0))) 51 | (is (eq nil (string-to-float nil 0))) 52 | (is (eql -12345678.123d0 (string-to-float "-12345678.123" 1))) 53 | (is (eql 12345678.123d0 (string-to-float "12345678.123" 1))) 54 | (is (eql 2.356d0 (string-to-float "2.356" 1))) 55 | (is (eql 12345678d0 (string-to-float "12345678" 1))) 56 | (is (eql 1.23456789012345678d308 (string-to-float "1.23456789012345678e+308" 1))) 57 | (is (eql 1.234567890123457d-308 (string-to-float "1.23456789012345678e-308" 1)))) 58 | 59 | (deftest test-string-to-date () 60 | (is (eq nil (string-to-date nil))) 61 | (is (eq nil (string-to-date ""))) 62 | (multiple-value-bind (h m s day mon year) 63 | (decode-universal-time (string-to-date "2009-01-01")) 64 | (is (and (eql 0 h) (eql 0 m) (eql 0 s) (eql 1 day) (eql 1 mon) (eql 2009 year)))) 65 | ;; Not sure how much it is worth investing in testing MySQL return values 66 | (is (eq nil (string-to-date "2009-1-1")))) 67 | 68 | (deftest test-string-to-seconds () 69 | (is (eq nil (string-to-seconds nil))) 70 | (is (eq nil (string-to-seconds ""))) 71 | (is (eq -1 (string-to-seconds "-00:00:01"))) 72 | (is (eql -3601 (string-to-seconds "-01:00:01"))) 73 | (is (eql 3023999 (string-to-seconds "839:59:59"))) 74 | (is (eql -3023999 (string-to-seconds "-839:59:59")))) 75 | 76 | (deftest test-extract-field () 77 | (cffi:with-foreign-object (ptr :pointer) 78 | (cffi:with-foreign-object (int :int) 79 | (setf (cffi:mem-ref int :int) (char-code #\1)) 80 | (setf (cffi:mem-ref ptr :pointer) int) 81 | (is (string= "1" (extract-field ptr 0 1 *type-map* '("one" :VARCHAR 0)))) 82 | (is (string= "1" (extract-field ptr 0 1 *type-map* '("one" :BLOB 16)))) 83 | (is (equalp (make-array 1 :initial-element (char-code #\1)) 84 | (extract-field ptr 0 1 *type-map* '("bit" :BIT 0)))) 85 | (is (equalp (make-array 1 :initial-element (char-code #\1)) 86 | (extract-field ptr 0 1 *type-map* '("bit" :BLOB 128)))) 87 | (setf (cffi:mem-ref ptr :pointer) (cffi:null-pointer)) 88 | (is (null (extract-field ptr 0 0 *type-map* '("space" :VARCHAR 0)))) 89 | (is (null (extract-field ptr 0 0 *type-map* '("bit" :BIT 0))))))) 90 | 91 | (deftest test-string-to-universal-time () 92 | (is (eq nil (string-to-universal-time nil))) 93 | (is (eq nil (string-to-universal-time ""))) 94 | (is (eq nil (string-to-universal-time "0000-00-00 00:00:00"))) 95 | (is (eql 1 96 | (- (string-to-universal-time "2009-01-01 00:00:00") 97 | (string-to-universal-time "2008-12-31 23:59:59"))))) 98 | 99 | 100 | (deftest test-string-to-ratio () 101 | (is (eq nil (string-to-ratio nil 1))) 102 | (is (eq nil (string-to-ratio "" 0))) 103 | (is (equal (/ 123123123 100000000) 104 | (string-to-ratio "1.23123123" 1))) 105 | (is (equal -1.23123123d0 106 | (coerce (string-to-ratio "-1.23123123" 1) 'double-float))) 107 | (is (eql 99999 (string-to-ratio "99999" 1))) 108 | (is (eql (/ 1 10) (string-to-ratio "0.1" 1)))) 109 | 110 | (deftest test-cffi-utf8-length () 111 | (cffi:with-foreign-string (s "€") 112 | #-windows(is (eql 3 (cffi-utf8-length s))) 113 | #+windows(is (eql 7 (cffi-utf8-length s))))) 114 | 115 | 116 | (defsuite* test-with-connection) 117 | 118 | (deftest test-setup () 119 | (connect :host *host* :user *user* :password *password*) 120 | (query "DROP DATABASE IF EXISTS cl_mysql_test; CREATE DATABASE cl_mysql_test; 121 | GRANT ALL ON cl_mysql_test.* TO USER(); FLUSH PRIVILEGES;") 122 | (use "cl_mysql_test") 123 | (query "CREATE TABLE test_table ( 124 | -- Integer numerics 125 | bt BIT(6), 126 | ti TINYINT UNSIGNED, 127 | si SMALLINT SIGNED, 128 | mi MEDIUMINT ZEROFILL, 129 | i INT(5) UNSIGNED, 130 | bi BIGINT UNSIGNED, 131 | -- Approximate numerics 132 | f FLOAT(7,4), 133 | r REAL(10,2), 134 | dp DOUBLE PRECISION(15,5), 135 | -- Precision numerics 136 | d DECIMAL(28,18), 137 | n NUMERIC(28,1), 138 | bg NUMERIC(65,0), 139 | -- Date and time 140 | dt DATETIME, 141 | da DATE, 142 | tm TIME, 143 | yr YEAR, 144 | ts TIMESTAMP DEFAULT CURRENT_TIMESTAMP, 145 | -- String types 146 | ch CHAR(10), 147 | vc VARCHAR(15), 148 | bn BINARY(7), 149 | vb VARBINARY(10), 150 | bb BLOB, 151 | tb TINYBLOB, 152 | mb MEDIUMBLOB, 153 | lb LONGBLOB, 154 | tt TINYTEXT, 155 | tx TEXT, 156 | mt MEDIUMTEXT, 157 | lt LONGTEXT, 158 | en ENUM ('small','medium','large'), 159 | st SET ('one','two'), 160 | -- Geomerty types 161 | ge GEOMETRY)") 162 | (is (eql 1 (length (list-tables)))) 163 | (query "INSERT INTO test_table (bt, ti, si, mi, i, bi, f, r, dp, d, n, 164 | dt, da, tm, yr, ch, vc, bn, vb, bb, tb, 165 | mb, lb, tt, tx, mt, lt, en, st, ge, bg) 166 | VALUES (b'100000', 255, -32768, 1, 4294967295, 18446744073709551615, 999.9999, 12312312.12, SQRT(2.0), 1.0/9.0, 1.0/9.0, 167 | '2009-12-31 00:00:00', '2009-12-31', '00:00:00', 2009, 'TEST1', 'TEST2', 'TEST3', 'TEST4', 'TEST5', 'TEST6', 168 | 'TEST7', 'TEST8', 'TEST9', 'TEST10', 'TEST11', 'TEST12', 'small','one,two',GeomFromText('POINT(1 1)'), 169 | 12345678901234567890123456789012345678901234567890123456789012345)") 170 | ;; Now confirm that the decoding via the type-maps is as we expect ... this 171 | ;; pretty much completes our integration test at a broad level 172 | (let ((result (caaar (query "SELECT * FROM test_table")))) 173 | (is (equalp #(32) (first result))) 174 | (is (eql 255 (second result))) 175 | (is (eql -32768 (third result))) 176 | (is (eql 1 (fourth result))) 177 | (is (eql 4294967295 (fifth result))) 178 | (is (eql 18446744073709551615 (sixth result))) 179 | (is (eql 999.9999d0 (seventh result))) 180 | (is (eql 12312312.12d0 (eighth result))) 181 | (is (eql 1.41421d0 (ninth result))) 182 | (is (eql (/ 111111111111111111 1000000000000000000) (tenth result))) 183 | (is (eql (/ 1 10) (nth 10 result))) 184 | (is (eql 12345678901234567890123456789012345678901234567890123456789012345 (nth 11 result))) 185 | ;; note that these values are time zone specific, so we only test that their 186 | ;; accurate to +- 1/2 day 187 | (is (< (abs (- 3471192000 (nth 12 result))) 43200)) 188 | (is (< (abs (- 3471192000 (nth 13 result))) 43200)) 189 | (is (eql 0 (nth 14 result))) 190 | (is (eql 2009 (nth 15 result))) 191 | (is (>= (nth 16 result) 3447985347)) 192 | (is (string= "TEST1" (nth 17 result))) 193 | (is (string= "TEST2" (nth 18 result))) 194 | (is (string= "TEST3" (nth 19 result))) 195 | (is (string= "TEST4" (nth 20 result))) 196 | (is (equalp #(84 69 83 84 53) (nth 21 result))) 197 | (is (equalp #(84 69 83 84 54) (nth 22 result))) 198 | (is (equalp #(84 69 83 84 55) (nth 23 result))) 199 | (is (equalp #(84 69 83 84 56) (nth 24 result))) 200 | (is (equalp "TEST9" (nth 25 result))) 201 | (is (equalp "TEST10" (nth 26 result))) 202 | (is (equalp "TEST11" (nth 27 result))) 203 | (is (equalp "TEST12" (nth 28 result))) 204 | (is (string= "small" (nth 29 result))) 205 | (is (string= "one,two" (nth 30 result))) 206 | (is (equalp #(0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 240 63 0 0 0 0 0 0 240 63) 207 | (nth 31 result)))) 208 | (query "DROP DATABASE cl_mysql_test") 209 | (disconnect)) 210 | 211 | (deftest test-escape-string () 212 | (connect :host *host* :user *user* :password *password*) 213 | (is (eq nil (escape-string nil))) 214 | (is (string= "" (escape-string ""))) 215 | (is (string= "\\\"" (escape-string "\""))) 216 | (is (string= "\\\'" (escape-string "'"))) 217 | (is (string= "\\n\\r" (escape-string (format nil "~C~C" 218 | (code-char 10) 219 | (code-char 13))))) 220 | (disconnect)) 221 | 222 | (deftest test-nth-row () 223 | (is (equalp '(100) (nth-row '((((100)))) 0))) 224 | (is (null (nth-row nil 10 10)))) 225 | 226 | (deftest test-use-result-1 () 227 | "Test out the self-service result set stuff. It works but it's a bit tricky to build 228 | a working result set/row processing loop ..." 229 | (connect :host *host* :user *user* :password *password*) 230 | (query "DROP DATABASE IF EXISTS cl_mysql_test; CREATE DATABASE cl_mysql_test; 231 | GRANT ALL ON cl_mysql_test.* TO USER(); FLUSH PRIVILEGES;") 232 | (use "cl_mysql_test") 233 | (query "CREATE TABLE X ( X INT ); INSERT INTO X (X) VALUES (1); INSERT INTO X (X) VALUES (2)") 234 | (let ((conn (query "SELECT * FROM X; SELECT * FROM X" :store nil))) 235 | (let ((total-rows 0)) 236 | (do ((result-set (next-result-set conn) (next-result-set conn))) 237 | ((null result-set)) 238 | (incf total-rows 239 | (do ((row (next-row conn) (next-row conn)) 240 | (nrows 0 (incf nrows))) 241 | ((null row) nrows)))) 242 | (is (eql 4 total-rows)))) 243 | ;; Now do it again using a loop style, the code is equivalent. This just documents 244 | ;; the two idioms for processing result sets. 245 | (let ((conn (query "SELECT * FROM X; SELECT * FROM X" :store nil))) 246 | (unwind-protect 247 | (is (eql 4 (loop while (next-result-set conn) 248 | summing (loop for row = (next-row conn) 249 | until (null row) 250 | count row)))))) 251 | ;; Now do it once more to verify we haven't got any result sets left open ... 252 | (is (eql 2 (length (query "SELECT * FROM X; SELECT * FROM X" :store t)))) 253 | (query "DROP DATABASE cl_mysql_test") 254 | (disconnect) 255 | (values)) 256 | 257 | (deftest test-use-result-2 () 258 | "We should be able to use two result sets simultaneously." 259 | (connect :host *host* :user *user* :password *password* 260 | :min-connections 2 :max-connections 2) 261 | (query "DROP DATABASE IF EXISTS cl_mysql_test; CREATE DATABASE cl_mysql_test; 262 | GRANT ALL ON cl_mysql_test.* TO USER(); FLUSH PRIVILEGES;") 263 | (use "cl_mysql_test") 264 | (query "CREATE TABLE X ( X INT ); INSERT INTO X (X) VALUES (10)") 265 | (let ((a (query "USE cl_mysql_test; SELECT * FROM X" :store nil)) 266 | (b (query "USE cl_mysql_test; SELECT * FROM X" :store nil))) 267 | (next-result-set a) (next-result-set a) 268 | (next-result-set b) (next-result-set b) 269 | (is (eql 100 (* (car (next-row a)) 270 | (car (next-row b))))) 271 | ;; Early release! 272 | (release a) 273 | (release b) 274 | (query "DROP DATABASE cl_mysql_test") 275 | (disconnect))) 276 | -------------------------------------------------------------------------------- /thread.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp -*- 2 | ;;;; $Id: ce547875af335730d756c87369a837d4e1035784 $ 3 | ;;;; 4 | ;;;; Copyright (c) 2009 Steve Knight 5 | ;;;; 6 | ;;;; Permission is hereby granted, free of charge, to any person obtaining 7 | ;;;; a copy of this software and associated documentation files (the 8 | ;;;; "Software"), to deal in the Software without restriction, including 9 | ;;;; without limitation the rights to use, copy, modify, merge, publish, 10 | ;;;; distribute, sublicense, and/or sell copies of the Software, and to 11 | ;;;; permit persons to whom the Software is furnished to do so, subject to 12 | ;;;; the following conditions: 13 | ;;;; 14 | ;;;; The above copyright notice and this permission notice shall be 15 | ;;;; included in all copies or substantial portions of the Software. 16 | ;;;; 17 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 19 | ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 21 | ;;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 22 | ;;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 23 | ;;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 24 | ;;;; 25 | (in-package "CL-MYSQL-SYSTEM") 26 | 27 | (defconstant *sleep-period* 0.1) 28 | 29 | ;;; Copied from bordeaux threads 30 | (eval-when (:compile-toplevel :load-toplevel :execute) 31 | #+(or (and allegro multiprocessing) 32 | armedbear 33 | (and cmu mp) 34 | scl 35 | corman 36 | (and digitool ccl-5.1) 37 | (and ecl threads) 38 | lispworks 39 | (and openmcl openmcl-native-threads) 40 | (and sbcl sb-thread) 41 | (and clisp mt)) 42 | (pushnew :thread-support *features*)) 43 | 44 | (eval-when (:load-toplevel) 45 | #+allegro (mp:start-scheduler)) 46 | 47 | (defun make-lock (name) 48 | #+sb-thread (sb-thread:make-mutex :name name) 49 | #+ecl (mp:make-lock :name name) 50 | #+armedbear (ext:make-thread-lock) 51 | #+ (and clisp mt) (mt:make-mutex :name name) 52 | #+allegro (mp:make-process-lock :name name)) 53 | 54 | (defun make-wait-resource () 55 | #+sb-thread (sb-thread:make-waitqueue) 56 | #+(and clisp mt) (mt:make-exemption)) 57 | 58 | (defun thread-alive-p (thread) 59 | #+ecl (mp:process-active-p thread) 60 | #+armedbear (ext:thread-alive-p thread) 61 | #- (or ecl sb-thread allegro (and clisp mt)) nil) 62 | 63 | (defun wait-on-threads (threads) 64 | #+sb-thread (mapcar #'sb-thread:join-thread threads) 65 | #+allegro (mapcar (lambda (p) 66 | (mp:process-wait "Joining ..." (lambda () 67 | (not (mp:process-alive-p p))))) threads) 68 | #-(or sb-thread allegro) (loop for th in threads 69 | do (loop until (not (thread-alive-p th)) 70 | do (sleep *sleep-period*)))) 71 | 72 | (defmacro with-lock (lock &body body) 73 | #+sb-thread `(sb-thread:with-recursive-lock (,lock) ,@body) 74 | #+allegro `(mp:with-process-lock (,lock) ,@body) 75 | #+(and clisp mt) `(mt:with-lock (,lock) ,@body) 76 | #+ecl `(mp:with-lock (,lock) ,@body) 77 | #+armedbear `(ext:with-thread-lock (,lock) ,@body) 78 | #-(or ecl sb-thread allegro) `(progn ,@body)) 79 | 80 | (defun start-thread-in-nsecs (fn n) 81 | #+sb-thread (sb-thread:make-thread (lambda () 82 | (sleep n) 83 | (funcall fn))) 84 | #+(and clisp mt) (mt:make-thread (lambda () 85 | (sleep n) 86 | (funcall fn)) nil) 87 | #+armedbear (ext:make-thread (lamba () 88 | (sleep n) 89 | (funcall fn)) :name nil) 90 | #+(or allegro ecl) (mp:process-run-function nil (lambda () 91 | (sleep n) 92 | (funcall fn)))) 93 | 94 | (defun pool-wait (pool) 95 | ;; With SBCL threads we can use condition variables to wake us up 96 | #+sb-thread (sb-thread:with-mutex ((wait-queue-lock pool)) 97 | (sb-thread:condition-wait (wait-queue pool) 98 | (wait-queue-lock pool))) 99 | ;; With Allegro CL we will use the process-wait to run a monitor thread 100 | ;; on the condition 101 | #+allegro (mp:process-wait "Waiting for pool" #'can-aquire-lock pool) 102 | #+(and clisp mt) (mt:exemption-wait (wait-queue pool) 103 | (wait-queue-lock pool)) 104 | #-(or allegro sb-thread (and clisp mt)) (sleep *sleep-period*)) 105 | 106 | (defun pool-notify (pool) 107 | #+(and clisp mt) (mt:exemption-signal (wait-queue pool)) 108 | #+sb-thread (sb-thread:with-mutex ((wait-queue-lock pool)) 109 | (sb-thread:condition-notify (wait-queue pool)))) 110 | 111 | --------------------------------------------------------------------------------