db-mysql/mysql-sql.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          mysql-sql.lisp
   6 ;;;; Purpose:       High-level MySQL interface using UFFI
   7 ;;;; Date Started:  Feb 2002
   8 ;;;;
   9 ;;;; $Id$
  10 ;;;;
  11 ;;;; CLSQL users are granted the rights to distribute and use this software
  12 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  13 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  14 ;;;; *************************************************************************
  15
  16 (defpackage #:clsql-mysql
  17     (:use #:common-lisp #:clsql-base-sys #:mysql #:clsql-uffi)
  18     (:export #:mysql-database)
  19     (:documentation "This is the CLSQL interface to MySQL."))
  20
  21 (in-package #:clsql-mysql)
  22
  23 ;;; Field conversion functions
  24
  25 (defun make-type-list-for-auto (num-fields res-ptr)
  26   (declare (fixnum num-fields))
  27   (let ((new-types '())
  28         #+ignore (field-vec (mysql-fetch-fields res-ptr)))
  29     (dotimes (i num-fields)
  30       (declare (fixnum i))
  31       (let* ( (field (mysql-fetch-field-direct res-ptr i))
  32              #+ignore (field (uffi:deref-array field-vec '(:array mysql-field) i))
  33               (type (uffi:get-slot-value field 'mysql-field 'type)))
  34         (push
  35          (case type
  36            ((#.mysql-field-types#tiny
  37              #.mysql-field-types#short
  38              #.mysql-field-types#int24
  39              #.mysql-field-types#long)
  40             :int32)
  41            (#.mysql-field-types#longlong
  42             :int64)
  43            ((#.mysql-field-types#double
  44              #.mysql-field-types#float
  45              #.mysql-field-types#decimal)
  46             :double)
  47            (otherwise
  48             t))
  49          new-types)))
  50     (nreverse new-types)))
  51
  52 (defun canonicalize-types (types num-fields res-ptr)
  53   (when types
  54     (let ((auto-list (make-type-list-for-auto num-fields res-ptr)))
  55       (cond
  56         ((listp types)
  57          (canonicalize-type-list types auto-list))
  58         ((eq types :auto)
  59          auto-list)
  60         (t
  61          nil)))))
  62
  63 (defmethod database-initialize-database-type ((database-type (eql :mysql)))
  64   t)
  65
  66 (uffi:def-type mysql-mysql-ptr-def (* mysql-mysql))
  67 (uffi:def-type mysql-row-def mysql-row)
  68 (uffi:def-type mysql-mysql-res-ptr-def (* mysql-mysql-res))
  69
  70 (defclass mysql-database (database)
  71   ((mysql-ptr :accessor database-mysql-ptr :initarg :mysql-ptr
  72               :type mysql-mysql-ptr-def)))
  73
  74 (defmethod database-type ((database mysql-database))
  75   :mysql)
  76
  77 (defmethod database-name-from-spec (connection-spec (database-type (eql :mysql)))
  78   (check-connection-spec connection-spec database-type (host db user password))
  79   (destructuring-bind (host db user password) connection-spec
  80     (declare (ignore password))
  81     (concatenate 'string
  82                  (if host host "localhost")
  83                  "/" db "/" user)))
  84
  85 (defmethod database-connect (connection-spec (database-type (eql :mysql)))
  86   (check-connection-spec connection-spec database-type (host db user password))
  87   (destructuring-bind (host db user password) connection-spec
  88     (let ((mysql-ptr (mysql-init (uffi:make-null-pointer 'mysql-mysql)))
  89           (socket nil))
  90       (if (uffi:null-pointer-p mysql-ptr)
  91           (error 'clsql-connect-error
  92                  :database-type database-type
  93                  :connection-spec connection-spec
  94                  :errno (mysql-errno mysql-ptr)
  95                  :error (mysql-error-string mysql-ptr))
  96         (uffi:with-cstrings ((host-native host)
  97                             (user-native user)
  98                             (password-native password)
  99                             (db-native db)
 100                             (socket-native socket))
 101           (let ((error-occurred nil))
 102             (unwind-protect
 103                 (if (uffi:null-pointer-p
 104                      (mysql-real-connect
 105                       mysql-ptr host-native user-native password-native
 106                       db-native 0 socket-native 0))
 107                     (progn
 108                       (setq error-occurred t)
 109                       (error 'clsql-connect-error
 110                              :database-type database-type
 111                              :connection-spec connection-spec
 112                              :errno (mysql-errno mysql-ptr)
 113                              :error (mysql-error-string mysql-ptr)))
 114                   (make-instance 'mysql-database
 115                     :name (database-name-from-spec connection-spec
 116                                                    database-type)
 117                     :database-type :mysql
 118                     :connection-spec connection-spec
 119                     :mysql-ptr mysql-ptr))
 120               (when error-occurred (mysql-close mysql-ptr)))))))))
 121
 122
 123 (defmethod database-disconnect ((database mysql-database))
 124   (mysql-close (database-mysql-ptr database))
 125   (setf (database-mysql-ptr database) nil)
 126   t)
 127
 128
 129 (defmethod database-query (query-expression (database mysql-database)
 130                            result-types)
 131   (declare (optimize (speed 3) (safety 0) (debug 0) (space 0)))
 132   (let ((mysql-ptr (database-mysql-ptr database)))
 133     (uffi:with-cstring (query-native query-expression)
 134       (if (zerop (mysql-real-query mysql-ptr query-native
 135                                    (length query-expression)))
 136           (let ((res-ptr (mysql-use-result mysql-ptr)))
 137             (if res-ptr
 138                 (unwind-protect
 139                      (let ((num-fields (mysql-num-fields res-ptr)))
 140                        (declare (fixnum num-fields))
 141                        (setq result-types (canonicalize-types
 142                                     result-types num-fields
 143                                     res-ptr))
 144                        (loop for row = (mysql-fetch-row res-ptr)
 145                              for lengths = (mysql-fetch-lengths res-ptr)
 146                              until (uffi:null-pointer-p row)
 147                            collect
 148                              (do* ((rlist (make-list num-fields))
 149                                    (i 0 (1+ i))
 150                                    (pos rlist (cdr pos)))
 151                                  ((= i num-fields) rlist)
 152                                (declare (fixnum i))
 153                                (setf (car pos)
 154                                  (convert-raw-field
 155                                   (uffi:deref-array row '(:array
 156                                                           (* :unsigned-char))
 157                                                     i)
 158                                   result-types i
 159                                   (uffi:deref-array lengths '(:array :unsigned-long)
 160                                                     i))))))
 161                   (mysql-free-result res-ptr))
 162                 (error 'clsql-sql-error
 163                        :database database
 164                        :expression query-expression
 165                        :errno (mysql-errno mysql-ptr)
 166                        :error (mysql-error-string mysql-ptr))))
 167           (error 'clsql-sql-error
 168                  :database database
 169                  :expression query-expression
 170                  :errno (mysql-errno mysql-ptr)
 171                  :error (mysql-error-string mysql-ptr))))))
 172
 173 (defmethod database-execute-command (sql-expression (database mysql-database))
 174   (uffi:with-cstring (sql-native sql-expression)
 175     (let ((mysql-ptr (database-mysql-ptr database)))
 176       (declare (type mysql-mysql-ptr-def mysql-ptr))
 177       (if (zerop (mysql-real-query mysql-ptr sql-native
 178                                    (length sql-expression)))
 179           t
 180         (error 'clsql-sql-error
 181                :database database
 182                :expression sql-expression
 183                :errno (mysql-errno mysql-ptr)
 184                :error (mysql-error-string mysql-ptr))))))
 185
 186
 187 (defstruct mysql-result-set
 188   (res-ptr (uffi:make-null-pointer 'mysql-mysql-res) :type mysql-mysql-res-ptr-def)
 189   (types nil :type list)
 190   (num-fields 0 :type fixnum)
 191   (full-set nil :type boolean))
 192
 193
 194 (defmethod database-query-result-set ((query-expression string)
 195                                       (database mysql-database)
 196                                       &key full-set result-types)
 197   (uffi:with-cstring (query-native query-expression)
 198     (let ((mysql-ptr (database-mysql-ptr database)))
 199      (declare (type mysql-mysql-ptr-def mysql-ptr))
 200       (if (zerop (mysql-real-query mysql-ptr query-native
 201                                    (length query-expression)))
 202           (let ((res-ptr (if full-set
 203                              (mysql-store-result mysql-ptr)
 204                            (mysql-use-result mysql-ptr))))
 205             (declare (type mysql-mysql-res-ptr-def res-ptr))
 206             (if (not (uffi:null-pointer-p res-ptr))
 207                 (let* ((num-fields (mysql-num-fields res-ptr))
 208                        (result-set (make-mysql-result-set
 209                                     :res-ptr res-ptr
 210                                     :num-fields num-fields
 211                                     :full-set full-set
 212                                     :types
 213                                     (canonicalize-types
 214                                      result-types num-fields
 215                                      res-ptr))))
 216                   (if full-set
 217                       (values result-set
 218                               num-fields
 219                               (mysql-num-rows res-ptr))
 220                       (values result-set
 221                               num-fields)))
 222                 (error 'clsql-sql-error
 223                      :database database
 224                      :expression query-expression
 225                      :errno (mysql-errno mysql-ptr)
 226                      :error (mysql-error-string mysql-ptr))))
 227         (error 'clsql-sql-error
 228                :database database
 229                :expression query-expression
 230                :errno (mysql-errno mysql-ptr)
 231                :error (mysql-error-string mysql-ptr))))))
 232
 233 (defmethod database-dump-result-set (result-set (database mysql-database))
 234   (mysql-free-result (mysql-result-set-res-ptr result-set))
 235   t)
 236
 237
 238 (defmethod database-store-next-row (result-set (database mysql-database) list)
 239   (let* ((res-ptr (mysql-result-set-res-ptr result-set))
 240          (row (mysql-fetch-row res-ptr))
 241          (lengths (mysql-fetch-lengths res-ptr))
 242          (types (mysql-result-set-types result-set)))
 243     (declare (type mysql-mysql-res-ptr-def res-ptr)
 244              (type mysql-row-def row))
 245     (unless (uffi:null-pointer-p row)
 246       (loop for i from 0 below (mysql-result-set-num-fields result-set)
 247             for rest on list
 248             do
 249             (setf (car rest)
 250                   (convert-raw-field
 251                    (uffi:deref-array row '(:array (* :unsigned-char)) i)
 252                    types
 253                    i
 254                    (uffi:deref-array lengths '(:array :unsigned-long) i))))
 255       list)))
 256
 257
 258 ;; Table and attribute introspection
 259
 260 (defmethod database-list-tables ((database mysql-database) &key (owner nil))
 261   (declare (ignore owner))
 262   (remove-if #'(lambda (s)
 263                  (and (>= (length s) 11)
 264                       (string= (subseq s 0 11) "_CLSQL_SEQ_")))
 265              (mapcar #'car (database-query "SHOW TABLES" database nil))))
 266
 267 ;; MySQL 4.1 does not support views
 268 (defmethod database-list-views ((database mysql-database)
 269                                 &key (owner nil))
 270   (declare (ignore owner))
 271   nil)
 272
 273 (defmethod database-list-indexes ((database mysql-database)
 274                                   &key (owner nil))
 275   (let ((result '()))
 276     (dolist (table (database-list-tables database :owner owner) result)
 277       (setq result
 278         (append (database-list-table-indexes table database :owner owner)
 279                 result)))))
 280
 281 (defmethod database-list-table-indexes (table (database mysql-database)
 282                                         &key (owner nil))
 283   (declare (ignore owner))
 284   (do ((results nil)
 285        (rows (database-query
 286               (format nil "SHOW INDEX FROM ~A" (string-upcase table))
 287               database nil)
 288              (cdr rows)))
 289       ((null rows) (nreverse results))
 290     (let ((col (nth 2 (car rows))))
 291       (unless (find col results :test #'string-equal)
 292         (push col results)))))
 293
 294 (defmethod database-list-attributes ((table string) (database mysql-database)
 295                                      &key (owner nil))
 296   (declare (ignore owner))
 297   (mapcar #'car
 298           (database-query
 299            (format nil "SHOW COLUMNS FROM ~A" table)
 300            database nil)))
 301
 302 (defmethod database-attribute-type (attribute (table string)
 303                                     (database mysql-database)
 304                                     &key (owner nil))
 305   (declare (ignore owner))
 306   (let ((result
 307          (mapcar #'cadr
 308                  (database-query
 309                   (format nil
 310                           "SHOW COLUMNS FROM ~A LIKE '~A'" table attribute)
 311                   database nil))))
 312     (let* ((str (car result))
 313            (end-str (position #\( str))
 314            (substr (subseq str 0 end-str)))
 315       (if substr
 316       (intern (string-upcase substr) :keyword) nil))))
 317
 318 ;;; Sequence functions
 319
 320 (defun %sequence-name-to-table (sequence-name)
 321   (concatenate 'string "_CLSQL_SEQ_" (sql-escape sequence-name)))
 322
 323 (defun %table-name-to-sequence-name (table-name)
 324   (and (>= (length table-name) 11)
 325        (string= (subseq table-name 0 11) "_CLSQL_SEQ_")
 326        (subseq table-name 11)))
 327
 328 (defmethod database-create-sequence (sequence-name
 329                                      (database mysql-database))
 330   (let ((table-name (%sequence-name-to-table sequence-name)))
 331     (database-execute-command
 332      (concatenate 'string "CREATE TABLE " table-name
 333                   " (id int NOT NULL PRIMARY KEY AUTO_INCREMENT)")
 334      database)
 335     (database-execute-command
 336      (concatenate 'string "INSERT INTO " table-name
 337                   " VALUES (-1)")
 338      database)))
 339
 340 (defmethod database-drop-sequence (sequence-name
 341                                    (database mysql-database))
 342   (database-execute-command
 343    (concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name))
 344    database))
 345
 346 (defmethod database-list-sequences ((database mysql-database)
 347                                     &key (owner nil))
 348   (declare (ignore owner))
 349   (mapcar #'(lambda (s) (%table-name-to-sequence-name (car s)))
 350           (database-query "SHOW TABLES LIKE '%clsql_seq%'"
 351                           database nil)))
 352
 353 (defmethod database-set-sequence-position (sequence-name
 354                                            (position integer)
 355                                            (database mysql-database))
 356   (database-execute-command
 357    (format nil "UPDATE ~A SET id=~A" (%sequence-name-to-table sequence-name)
 358            position)
 359    database)
 360   (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database)))
 361
 362 (defmethod database-sequence-next (sequence-name (database mysql-database))
 363   (without-interrupts
 364    (database-execute-command
 365     (concatenate 'string "UPDATE " (%sequence-name-to-table sequence-name)
 366                  " SET id=LAST_INSERT_ID(id+1)")
 367     database)
 368    (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database))))
 369
 370 (defmethod database-sequence-last (sequence-name (database mysql-database))
 371   (declare (ignore sequence-name)))
 372
 373 (defmethod database-create (connection-spec (type (eql :mysql)))
 374   (destructuring-bind (host name user password) connection-spec
 375     (multiple-value-bind (output status)
 376         (clsql-base-sys:command-output "mysqladmin create -u~A -p~A -h~A ~A"
 377                                        user password
 378                                        (if host host "localhost")
 379                                        name)
 380       (if (or (not (eql 0 status))
 381               (and (search "failed" output) (search "error" output)))
 382           (error 'clsql-access-error
 383                  :connection-spec connection-spec
 384                  :database-type type
 385                  :error
 386                  (format nil "database-create failed: ~A" output))
 387           t))))
 388
 389 (defmethod database-destroy (connection-spec (type (eql :mysql)))
 390   (destructuring-bind (host name user password) connection-spec
 391     (multiple-value-bind (output status)
 392         (clsql-base-sys:command-output "mysqladmin drop -f -u~A -p~A -h~A ~A"
 393                                        user password
 394                                        (if host host "localhost")
 395                                        name)
 396       (if (or (not (eql 0 status))
 397               (and (search "failed" output) (search "error" output)))
 398           (error 'clsql-access-error
 399                  :connection-spec connection-spec
 400                  :database-type type
 401                  :error
 402                  (format nil "database-destroy failed: ~A" output))
 403         t))))
 404
 405 (defmethod database-probe (connection-spec (type (eql :mysql)))
 406   (when (find (second connection-spec) (database-list connection-spec type)
 407               :key #'car :test #'string-equal)
 408     t))
 409
 410 (defmethod database-list (connection-spec (type (eql :mysql)))
 411   (destructuring-bind (host name user password) connection-spec
 412     (declare (ignore name))
 413     (let ((database (database-connect (list host "mysql" user password) type)))
 414       (unwind-protect
 415            (progn
 416              (setf (slot-value database 'clsql-base-sys::state) :open)
 417              (mapcar #'car (database-query "show databases" database :auto)))
 418         (progn
 419           (database-disconnect database)
 420           (setf (slot-value database 'clsql-base-sys::state) :closed))))))
 421
 422 ;;; Database capabilities
 423
 424 (defmethod db-type-use-column-on-drop-index? ((db-type (eql :mysql)))
 425   t)
 426
 427 (defmethod db-type-has-views? ((db-type (eql :mysql)))
 428   ;; MySQL 4.1 will apparently have views, need to check *mysql-client-info*
 429   nil)
 430
 431 (defmethod db-type-has-subqueries? ((db-type (eql :mysql)))
 432   ;; MySQL 4.1 will apparently have subqueries, need to check *mysql-client-info*
 433   nil)
 434
 435 (defmethod db-type-has-boolean-where? ((db-type (eql :mysql)))
 436   nil)
 437
 438 (defmethod db-type-transaction-capable? ((db-type (eql :mysql)) database)
 439   (let ((has-innodb (caar (database-query "SHOW VARIABLES LIKE 'HAVE_INNODB'" database :auto))))
 440     (and has-innodb (string-equal "YES" has-innodb))))
 441
 442
 443 (when (clsql-base-sys:database-type-library-loaded :mysql)
 444   (clsql-base-sys:initialize-database-type :database-type :mysql))
 445