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