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                     :connection-spec connection-spec
 118                     :mysql-ptr mysql-ptr))
 119               (when error-occurred (mysql-close mysql-ptr)))))))))
 120
 121
 122 (defmethod database-disconnect ((database mysql-database))
 123   (mysql-close (database-mysql-ptr database))
 124   (setf (database-mysql-ptr database) nil)
 125   t)
 126
 127
 128 (defmethod database-query (query-expression (database mysql-database)
 129                            result-types)
 130   (declare (optimize (speed 3) (safety 0) (debug 0) (space 0)))
 131   (let ((mysql-ptr (database-mysql-ptr database)))
 132     (uffi:with-cstring (query-native query-expression)
 133       (if (zerop (mysql-real-query mysql-ptr query-native
 134                                    (length query-expression)))
 135           (let ((res-ptr (mysql-use-result mysql-ptr)))
 136             (if res-ptr
 137                 (unwind-protect
 138                      (let ((num-fields (mysql-num-fields res-ptr)))
 139                        (declare (fixnum num-fields))
 140                        (setq result-types (canonicalize-types
 141                                     result-types num-fields
 142                                     res-ptr))
 143                        (loop for row = (mysql-fetch-row res-ptr)
 144                              for lengths = (mysql-fetch-lengths res-ptr)
 145                              until (uffi:null-pointer-p row)
 146                            collect
 147                              (do* ((rlist (make-list num-fields))
 148                                    (i 0 (1+ i))
 149                                    (pos rlist (cdr pos)))
 150                                  ((= i num-fields) rlist)
 151                                (declare (fixnum i))
 152                                (setf (car pos)
 153                                  (convert-raw-field
 154                                   (uffi:deref-array row '(:array
 155                                                           (* :unsigned-char))
 156                                                     i)
 157                                   result-types i
 158                                   (uffi:deref-array lengths '(:array :unsigned-long)
 159                                                     i))))))
 160                   (mysql-free-result res-ptr))
 161                 (error 'clsql-sql-error
 162                        :database database
 163                        :expression query-expression
 164                        :errno (mysql-errno mysql-ptr)
 165                        :error (mysql-error-string mysql-ptr))))
 166           (error 'clsql-sql-error
 167                  :database database
 168                  :expression query-expression
 169                  :errno (mysql-errno mysql-ptr)
 170                  :error (mysql-error-string mysql-ptr))))))
 171
 172 #+ignore
 173 (defmethod database-query (query-expression (database mysql-database)
 174                            result-types)
 175   (declare (optimize (speed 3) (safety 0) (debug 0) (space 0)))
 176   (let ((mysql-ptr (database-mysql-ptr database)))
 177     (uffi:with-cstring (query-native query-expression)
 178       (if (zerop (mysql-query mysql-ptr query-native))
 179           (let ((res-ptr (mysql-use-result mysql-ptr)))
 180             (if res-ptr
 181                 (unwind-protect
 182                      (let ((num-fields (mysql-num-fields res-ptr)))
 183                        (declare (fixnum num-fields))
 184                        (setq result-types (canonicalize-types
 185                                     result-types num-fields
 186                                     res-ptr))
 187                        (loop for row = (mysql-fetch-row res-ptr)
 188                              until (uffi:null-pointer-p row)
 189                              collect
 190                              (loop for i fixnum from 0 below num-fields
 191                                    collect
 192                                    (convert-raw-field
 193                                     (uffi:deref-array row '(:array
 194                                                             (* :unsigned-char))
 195                                                       i)
 196                                     result-types i))))
 197                   (mysql-free-result res-ptr))
 198                 (error 'clsql-sql-error
 199                        :database database
 200                        :expression query-expression
 201                        :errno (mysql-errno mysql-ptr)
 202                        :error (mysql-error-string mysql-ptr))))
 203           (error 'clsql-sql-error
 204                  :database database
 205                  :expression query-expression
 206                  :errno (mysql-errno mysql-ptr)
 207                  :error (mysql-error-string mysql-ptr))))))
 208
 209 (defmethod database-execute-command (sql-expression (database mysql-database))
 210   (uffi:with-cstring (sql-native sql-expression)
 211     (let ((mysql-ptr (database-mysql-ptr database)))
 212       (declare (type mysql-mysql-ptr-def mysql-ptr))
 213       (if (zerop (mysql-real-query mysql-ptr sql-native
 214                                    (length sql-expression)))
 215           t
 216         (error 'clsql-sql-error
 217                :database database
 218                :expression sql-expression
 219                :errno (mysql-errno mysql-ptr)
 220                :error (mysql-error-string mysql-ptr))))))
 221
 222
 223 (defstruct mysql-result-set
 224   (res-ptr (uffi:make-null-pointer 'mysql-mysql-res) :type mysql-mysql-res-ptr-def)
 225   (types nil :type list)
 226   (num-fields 0 :type fixnum)
 227   (full-set nil :type boolean))
 228
 229
 230 (defmethod database-query-result-set ((query-expression string)
 231                                       (database mysql-database)
 232                                       &key full-set result-types)
 233   (uffi:with-cstring (query-native query-expression)
 234     (let ((mysql-ptr (database-mysql-ptr database)))
 235      (declare (type mysql-mysql-ptr-def mysql-ptr))
 236       (if (zerop (mysql-real-query mysql-ptr query-native
 237                                    (length query-expression)))
 238           (let ((res-ptr (if full-set
 239                              (mysql-store-result mysql-ptr)
 240                            (mysql-use-result mysql-ptr))))
 241             (declare (type mysql-mysql-res-ptr-def res-ptr))
 242             (if (not (uffi:null-pointer-p res-ptr))
 243                 (let* ((num-fields (mysql-num-fields res-ptr))
 244                        (result-set (make-mysql-result-set
 245                                     :res-ptr res-ptr
 246                                     :num-fields num-fields
 247                                     :full-set full-set
 248                                     :types
 249                                     (canonicalize-types
 250                                      result-types num-fields
 251                                      res-ptr))))
 252                   (if full-set
 253                       (values result-set
 254                               num-fields
 255                               (mysql-num-rows res-ptr))
 256                       (values result-set
 257                               num-fields)))
 258                 (error 'clsql-sql-error
 259                      :database database
 260                      :expression query-expression
 261                      :errno (mysql-errno mysql-ptr)
 262                      :error (mysql-error-string mysql-ptr))))
 263         (error 'clsql-sql-error
 264                :database database
 265                :expression query-expression
 266                :errno (mysql-errno mysql-ptr)
 267                :error (mysql-error-string mysql-ptr))))))
 268
 269 (defmethod database-dump-result-set (result-set (database mysql-database))
 270   (mysql-free-result (mysql-result-set-res-ptr result-set))
 271   t)
 272
 273
 274 (defmethod database-store-next-row (result-set (database mysql-database) list)
 275   (let* ((res-ptr (mysql-result-set-res-ptr result-set))
 276          (row (mysql-fetch-row res-ptr))
 277          (lengths (mysql-fetch-lengths res-ptr))
 278          (types (mysql-result-set-types result-set)))
 279     (declare (type mysql-mysql-res-ptr-def res-ptr)
 280              (type mysql-row-def row))
 281     (unless (uffi:null-pointer-p row)
 282       (loop for i from 0 below (mysql-result-set-num-fields result-set)
 283             for rest on list
 284             do
 285             (setf (car rest)
 286                   (convert-raw-field
 287                    (uffi:deref-array row '(:array (* :unsigned-char)) i)
 288                    types
 289                    i
 290                    (uffi:deref-array lengths '(:array :unsigned-long) i))))
 291       list)))
 292
 293
 294 ;; Table and attribute introspection
 295
 296 (defmethod database-list-tables ((database mysql-database) &key (owner nil))
 297   (declare (ignore owner))
 298   (remove-if #'(lambda (s)
 299                  (and (>= (length s) 11)
 300                       (string= (subseq s 0 11) "_clsql_seq_")))
 301              (mapcar #'car (database-query "SHOW TABLES" database nil))))
 302
 303 ;; MySQL 4.1 does not support views
 304 (defmethod database-list-views ((database mysql-database)
 305                                 &key (owner nil))
 306   (declare (ignore owner))
 307   nil)
 308
 309 (defmethod database-list-indexes ((database mysql-database)
 310                                   &key (owner nil))
 311   (let ((result '()))
 312     (dolist (table (database-list-tables database :owner owner) result)
 313       (mapc #'(lambda (index) (push (nth 2 index) result))
 314             (database-query
 315              (format nil "SHOW INDEX FROM ~A" (string-upcase table))
 316              database nil)))))
 317
 318 (defmethod database-list-attributes ((table string) (database mysql-database)
 319                                      &key (owner nil))
 320   (declare (ignore owner))
 321   (mapcar #'car
 322           (database-query
 323            (format nil "SHOW COLUMNS FROM ~A" table)
 324            database nil)))
 325
 326 (defmethod database-attribute-type (attribute (table string)
 327                                     (database mysql-database)
 328                                     &key (owner nil))
 329   (declare (ignore owner))
 330   (let ((result
 331          (mapcar #'cadr
 332                  (database-query
 333                   (format nil
 334                           "SHOW COLUMNS FROM ~A LIKE '~A'" table attribute)
 335                   database nil))))
 336     (let* ((str (car result))
 337            (end-str (position #\( str))
 338            (substr (subseq str 0 end-str)))
 339       (if substr
 340       (intern (string-upcase substr) :keyword) nil))))
 341
 342 ;;; Sequence functions
 343
 344 (defun %sequence-name-to-table (sequence-name)
 345   (concatenate 'string "_clsql_seq_" (sql-escape sequence-name)))
 346
 347 (defun %table-name-to-sequence-name (table-name)
 348   (and (>= (length table-name) 11)
 349        (string= (subseq table-name 0 11) "_clsql_seq_")
 350        (subseq table-name 11)))
 351
 352 (defmethod database-create-sequence (sequence-name
 353                                      (database mysql-database))
 354   (let ((table-name (%sequence-name-to-table sequence-name)))
 355     (database-execute-command
 356      (concatenate 'string "CREATE TABLE " table-name
 357                   " (id int NOT NULL PRIMARY KEY AUTO_INCREMENT)")
 358      database)
 359     (database-execute-command
 360      (concatenate 'string "INSERT INTO " table-name
 361                   " VALUES (-1)")
 362      database)))
 363
 364 (defmethod database-drop-sequence (sequence-name
 365                                    (database mysql-database))
 366   (database-execute-command
 367    (concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name))
 368    database))
 369
 370 (defmethod database-list-sequences ((database mysql-database)
 371                                     &key (owner nil))
 372   (declare (ignore owner))
 373   (mapcar #'(lambda (s) (%table-name-to-sequence-name (car s)))
 374           (database-query "SHOW TABLES LIKE '%clsql_seq%'"
 375                           database nil)))
 376
 377 (defmethod database-set-sequence-position (sequence-name
 378                                            (position integer)
 379                                            (database mysql-database))
 380   (database-execute-command
 381    (format nil "UPDATE ~A SET id=~A" (%sequence-name-to-table sequence-name)
 382            position)
 383    database)
 384   (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database)))
 385
 386 (defmethod database-sequence-next (sequence-name (database mysql-database))
 387   (database-execute-command
 388    (concatenate 'string "UPDATE " (%sequence-name-to-table sequence-name)
 389                 " SET id=LAST_INSERT_ID(id+1)")
 390    database)
 391   (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database)))
 392
 393 (defmethod database-sequence-last (sequence-name (database mysql-database))
 394   (declare (ignore sequence-name)))
 395
 396
 397
 398 (defmethod database-create (connection-spec (type (eql :mysql)))
 399   (destructuring-bind (host name user password) connection-spec
 400     (multiple-value-bind (output status)
 401         (clsql-base-sys:command-output "mysqladmin create -u~A -p~A -h~A ~A"
 402                                        user password
 403                                        (if host host "localhost")
 404                                        name)
 405       (if (or (not (eql 0 status))
 406               (and (search "failed" output) (search "error" output)))
 407           (error 'clsql-access-error
 408                  :connection-spec connection-spec
 409                  :database-type type
 410                  :error
 411                  (format nil "database-create failed: ~A" output))
 412           t))))
 413
 414 (defmethod database-destory (connection-spec (type (eql :mysql)))
 415   (destructuring-bind (host name user password) connection-spec
 416     (multiple-value-bind (output status)
 417         (clsql-base-sys:command-output "mysqladmin drop -u~A -p~A -h~A ~A"
 418                                        user password
 419                                        (if host host "localhost")
 420                                        name)
 421       (if (or (not (eql 0 status))
 422               (and (search "failed" output) (search "error" output)))
 423           (error 'clsql-access-error
 424                  :connection-spec connection-spec
 425                  :database-type type
 426                  :error
 427                  (format nil "database-destroy failed: ~A" output))
 428         t))))
 429
 430 (defmethod database-probe (connection-spec (type (eql :mysql)))
 431   (destructuring-bind (host name user password) connection-spec
 432     (let ((database (database-connect (list host "mysql" user password) type)))
 433       (unwind-protect
 434           (when
 435               (find name (database-query "select db from db"
 436                                          database :auto)
 437                     :key #'car :test #'string-equal)
 438             t)
 439         (database-disconnect database)))))
 440
 441
 442 (when (clsql-base-sys:database-type-library-loaded :mysql)
 443   (clsql-base-sys:initialize-database-type :database-type :mysql))