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