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 ;;;; Programmers:   Kevin M. Rosenberg based on
   8 ;;;;                Original code by Pierre R. Mai
   9 ;;;; Date Started:  Feb 2002
  10 ;;;;
  11 ;;;; $Id$
  12 ;;;;
  13 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
  14 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
  15 ;;;;
  16 ;;;; CLSQL users are granted the rights to distribute and use this software
  17 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  18 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  19 ;;;; *************************************************************************
  20
  21 (eval-when (:compile-toplevel)
  22   (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))))
  23
  24 ;;;; Modified by Kevin Rosenberg, Feb 20002
  25 ;;;; -- Added support for Allegro CL and Lispworks using UFFI layer
  26 ;;;; -- Changed database-connect to use mysql-real-connect. This way,
  27 ;;;;    can avoid using double (unwind-protect)
  28 ;;;; -- Changed database-connect to have MySQL library allocate space
  29 ;;;;    for MYSQL structure. This will make the code more robust in
  30 ;;;;    the event that MySQL library changes the size of the mysql-mysql
  31 ;;;;    structure.
  32 ;;;;
  33 ;;;; Mar 2002
  34 ;;;; Added field types
  35
  36 (defpackage #:clsql-mysql
  37     (:use #:common-lisp #:clsql-base-sys #:mysql #:clsql-uffi)
  38     (:export #:mysql-database)
  39     (:documentation "This is the CLSQL interface to MySQL."))
  40
  41 (in-package #:clsql-mysql)
  42
  43 ;;; Field conversion functions
  44
  45 (defun make-type-list-for-auto (num-fields res-ptr)
  46   (declare (fixnum num-fields))
  47   (let ((new-types '())
  48         #+ignore (field-vec (mysql-fetch-fields res-ptr)))
  49     (dotimes (i num-fields)
  50       (declare (fixnum i))
  51       (let* ( (field (mysql-fetch-field-direct res-ptr i))
  52              #+ignore (field (uffi:deref-array field-vec '(:array mysql-field) i))
  53               (type (uffi:get-slot-value field 'mysql-field 'type)))
  54         (push
  55          (case type
  56            ((#.mysql-field-types#tiny
  57              #.mysql-field-types#short
  58              #.mysql-field-types#int24
  59              #.mysql-field-types#long)
  60             :int32)
  61            (#.mysql-field-types#longlong
  62             :int64)
  63            ((#.mysql-field-types#double
  64              #.mysql-field-types#float
  65              #.mysql-field-types#decimal)
  66             :double)
  67            (otherwise
  68             t))
  69          new-types)))
  70     (nreverse new-types)))
  71
  72 (defun canonicalize-types (types num-fields res-ptr)
  73   (when types
  74     (let ((auto-list (make-type-list-for-auto num-fields res-ptr)))
  75       (cond
  76         ((listp types)
  77          (canonicalize-type-list types auto-list))
  78         ((eq types :auto)
  79          auto-list)
  80         (t
  81          nil)))))
  82
  83 (defmethod database-initialize-database-type ((database-type (eql :mysql)))
  84   t)
  85
  86 (uffi:def-type mysql-mysql-ptr-def (* mysql-mysql))
  87 (uffi:def-type mysql-row-def mysql-row)
  88 (uffi:def-type mysql-mysql-res-ptr-def (* mysql-mysql-res))
  89
  90 (defclass mysql-database (database)
  91   ((mysql-ptr :accessor database-mysql-ptr :initarg :mysql-ptr
  92               :type mysql-mysql-ptr-def)))
  93
  94 (defmethod database-type ((database mysql-database))
  95   :mysql)
  96
  97 (defmethod database-name-from-spec (connection-spec (database-type (eql :mysql)))
  98   (check-connection-spec connection-spec database-type (host db user password))
  99   (destructuring-bind (host db user password) connection-spec
 100     (declare (ignore password))
 101     (concatenate 'string host "/" db "/" user)))
 102
 103 (defmethod database-connect (connection-spec (database-type (eql :mysql)))
 104   (check-connection-spec connection-spec database-type (host db user password))
 105   (destructuring-bind (host db user password) connection-spec
 106     (let ((mysql-ptr (mysql-init (uffi:make-null-pointer 'mysql-mysql)))
 107           (socket nil))
 108       (if (uffi:null-pointer-p mysql-ptr)
 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         (uffi:with-cstrings ((host-native host)
 115                             (user-native user)
 116                             (password-native password)
 117                             (db-native db)
 118                             (socket-native socket))
 119           (let ((error-occurred nil))
 120             (unwind-protect
 121                 (if (uffi:null-pointer-p
 122                      (mysql-real-connect
 123                       mysql-ptr host-native user-native password-native
 124                       db-native 0 socket-native 0))
 125                     (progn
 126                       (setq error-occurred t)
 127                       (error 'clsql-connect-error
 128                              :database-type database-type
 129                              :connection-spec connection-spec
 130                              :errno (mysql-errno mysql-ptr)
 131                              :error (mysql-error-string mysql-ptr)))
 132                   (make-instance 'mysql-database
 133                     :name (database-name-from-spec connection-spec
 134                                                    database-type)
 135                     :connection-spec connection-spec
 136                     :mysql-ptr mysql-ptr))
 137               (when error-occurred (mysql-close mysql-ptr)))))))))
 138
 139
 140 (defmethod database-disconnect ((database mysql-database))
 141   (mysql-close (database-mysql-ptr database))
 142   (setf (database-mysql-ptr database) nil)
 143   t)
 144
 145
 146 (defmethod database-query (query-expression (database mysql-database)
 147                            types)
 148   (declare (optimize (speed 3) (safety 0) (debug 0) (space 0)))
 149   (let ((mysql-ptr (database-mysql-ptr database)))
 150     (uffi:with-cstring (query-native query-expression)
 151       (if (zerop (mysql-real-query mysql-ptr query-native
 152                                    (length query-expression)))
 153           (let ((res-ptr (mysql-use-result mysql-ptr)))
 154             (if res-ptr
 155                 (unwind-protect
 156                      (let ((num-fields (mysql-num-fields res-ptr)))
 157                        (declare (fixnum num-fields))
 158                        (setq types (canonicalize-types
 159                                     types num-fields
 160                                     res-ptr))
 161                        (loop for row = (mysql-fetch-row res-ptr)
 162                              for lengths = (mysql-fetch-lengths res-ptr)
 163                              until (uffi:null-pointer-p row)
 164                            collect
 165                              (do* ((rlist (make-list num-fields))
 166                                    (i 0 (1+ i))
 167                                    (pos rlist (cdr pos)))
 168                                  ((= i num-fields) rlist)
 169                                (declare (fixnum i))
 170                                (setf (car pos)
 171                                  (convert-raw-field
 172                                   (uffi:deref-array row '(:array
 173                                                           (* :unsigned-char))
 174                                                     i)
 175                                   types i
 176                                   (uffi:deref-array lengths '(:array :unsigned-long)
 177                                                     i))))))
 178                   (mysql-free-result res-ptr))
 179                 (error 'clsql-sql-error
 180                        :database database
 181                        :expression query-expression
 182                        :errno (mysql-errno mysql-ptr)
 183                        :error (mysql-error-string mysql-ptr))))
 184           (error 'clsql-sql-error
 185                  :database database
 186                  :expression query-expression
 187                  :errno (mysql-errno mysql-ptr)
 188                  :error (mysql-error-string mysql-ptr))))))
 189
 190 #+ignore
 191 (defmethod database-query (query-expression (database mysql-database)
 192                            types)
 193   (declare (optimize (speed 3) (safety 0) (debug 0) (space 0)))
 194   (let ((mysql-ptr (database-mysql-ptr database)))
 195     (uffi:with-cstring (query-native query-expression)
 196       (if (zerop (mysql-query mysql-ptr query-native))
 197           (let ((res-ptr (mysql-use-result mysql-ptr)))
 198             (if res-ptr
 199                 (unwind-protect
 200                      (let ((num-fields (mysql-num-fields res-ptr)))
 201                        (declare (fixnum num-fields))
 202                        (setq types (canonicalize-types
 203                                     types num-fields
 204                                     res-ptr))
 205                        (loop for row = (mysql-fetch-row res-ptr)
 206                              until (uffi:null-pointer-p row)
 207                              collect
 208                              (loop for i fixnum from 0 below num-fields
 209                                    collect
 210                                    (convert-raw-field
 211                                     (uffi:deref-array row '(:array
 212                                                             (* :unsigned-char))
 213                                                       i)
 214                                     types i))))
 215                   (mysql-free-result res-ptr))
 216                 (error 'clsql-sql-error
 217                        :database database
 218                        :expression query-expression
 219                        :errno (mysql-errno mysql-ptr)
 220                        :error (mysql-error-string mysql-ptr))))
 221           (error 'clsql-sql-error
 222                  :database database
 223                  :expression query-expression
 224                  :errno (mysql-errno mysql-ptr)
 225                  :error (mysql-error-string mysql-ptr))))))
 226
 227 (defmethod database-execute-command (sql-expression (database mysql-database))
 228   (uffi:with-cstring (sql-native sql-expression)
 229     (let ((mysql-ptr (database-mysql-ptr database)))
 230       (declare (type mysql-mysql-ptr-def mysql-ptr))
 231       (if (zerop (mysql-real-query mysql-ptr sql-native
 232                                    (length sql-expression)))
 233           t
 234         (error 'clsql-sql-error
 235                :database database
 236                :expression sql-expression
 237                :errno (mysql-errno mysql-ptr)
 238                :error (mysql-error-string mysql-ptr))))))
 239
 240
 241 (defstruct mysql-result-set
 242   (res-ptr (uffi:make-null-pointer 'mysql-mysql-res) :type mysql-mysql-res-ptr-def)
 243   (types nil :type list)
 244   (num-fields 0 :type fixnum)
 245   (full-set nil :type boolean))
 246
 247
 248 (defmethod database-query-result-set (query-expression
 249                                       (database mysql-database)
 250                                       &key full-set types)
 251   (uffi:with-cstring (query-native query-expression)
 252     (let ((mysql-ptr (database-mysql-ptr database)))
 253      (declare (type mysql-mysql-ptr-def mysql-ptr))
 254       (if (zerop (mysql-real-query mysql-ptr query-native
 255                                    (length query-expression)))
 256           (let ((res-ptr (if full-set
 257                              (mysql-store-result mysql-ptr)
 258                            (mysql-use-result mysql-ptr))))
 259             (declare (type mysql-mysql-res-ptr-def res-ptr))
 260             (if (not (uffi:null-pointer-p res-ptr))
 261                 (let* ((num-fields (mysql-num-fields res-ptr))
 262                        (result-set (make-mysql-result-set
 263                                     :res-ptr res-ptr
 264                                     :num-fields num-fields
 265                                     :full-set full-set
 266                                     :types
 267                                     (canonicalize-types
 268                                      types num-fields
 269                                      res-ptr))))
 270                   (if full-set
 271                       (values result-set
 272                               num-fields
 273                               (mysql-num-rows res-ptr))
 274                       (values result-set
 275                               num-fields)))
 276                 (error 'clsql-sql-error
 277                      :database database
 278                      :expression query-expression
 279                      :errno (mysql-errno mysql-ptr)
 280                      :error (mysql-error-string mysql-ptr))))
 281         (error 'clsql-sql-error
 282                :database database
 283                :expression query-expression
 284                :errno (mysql-errno mysql-ptr)
 285                :error (mysql-error-string mysql-ptr))))))
 286
 287 (defmethod database-dump-result-set (result-set (database mysql-database))
 288   (mysql-free-result (mysql-result-set-res-ptr result-set))
 289   t)
 290
 291
 292 (defmethod database-store-next-row (result-set (database mysql-database) list)
 293   (let* ((res-ptr (mysql-result-set-res-ptr result-set))
 294          (row (mysql-fetch-row res-ptr))
 295          (lengths (mysql-fetch-lengths res-ptr))
 296          (types (mysql-result-set-types result-set)))
 297     (declare (type mysql-mysql-res-ptr-def res-ptr)
 298              (type mysql-row-def row))
 299     (unless (uffi:null-pointer-p row)
 300       (loop for i from 0 below (mysql-result-set-num-fields result-set)
 301             for rest on list
 302             do
 303             (setf (car rest)
 304                   (convert-raw-field
 305                    (uffi:deref-array row '(:array (* :unsigned-char)) i)
 306                    types
 307                    i
 308                    (uffi:deref-array lengths :unsigned-long i))))
 309       list)))
 310
 311
 312 (when (clsql-base-sys:database-type-library-loaded :mysql)
 313   (clsql-base-sys:initialize-database-type :database-type :mysql))