db-mysql/mysql-sql.cl

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          mysql-sql.cl
   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: mysql-sql.cl,v 1.3 2002/09/30 02:07:42 kevin Exp $
  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 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
  22
  23 ;;;; Modified by Kevin Rosenberg, Feb 20002
  24 ;;;; -- Added support for Allegro CL and Lispworks using UFFI layer
  25 ;;;; -- Changed database-connect to use mysql-real-connect. This way,
  26 ;;;;    can avoid using double (unwind-protect)
  27 ;;;; -- Changed database-connect to have MySQL library allocate space
  28 ;;;;    for MYSQL structure. This will make the code more robust in
  29 ;;;;    the event that MySQL library changes the size of the mysql-mysql
  30 ;;;;    structure.
  31 ;;;;
  32 ;;;; Mar 2002
  33 ;;;; Added field types
  34
  35 (defpackage :clsql-mysql
  36     (:use :common-lisp :clsql-base-sys :mysql :clsql-uffi)
  37     (:export #:mysql-database)
  38     (:documentation "This is the CLSQL interface to MySQL."))
  39
  40 (in-package :clsql-mysql)
  41
  42 ;;; Field conversion functions
  43
  44 (defun make-type-list-for-auto (num-fields res-ptr)
  45   (let ((new-types '())
  46         #+ignore (field-vec (mysql-fetch-fields res-ptr)))
  47     (dotimes (i num-fields)
  48       (declare (fixnum i))
  49       (let* ( (field (mysql-fetch-field-direct res-ptr i))
  50              #+ignore (field (uffi:deref-array field-vec '(:array mysql-field) i))
  51               (type (uffi:get-slot-value field 'mysql-field 'type)))
  52         (push
  53          (case type
  54            ((#.mysql-field-types#tiny
  55              #.mysql-field-types#short
  56              #.mysql-field-types#int24
  57              #.mysql-field-types#long)
  58             :int32)
  59            (#.mysql-field-types#longlong
  60             :int64)
  61            ((#.mysql-field-types#double
  62              #.mysql-field-types#float
  63              #.mysql-field-types#decimal)
  64             :double)
  65            (otherwise
  66             t))
  67          new-types)))
  68     (nreverse new-types)))
  69
  70 (defun canonicalize-types (types num-fields res-ptr)
  71   (if (null types)
  72       nil
  73       (let ((auto-list (make-type-list-for-auto num-fields res-ptr)))
  74         (cond
  75           ((listp types)
  76            (canonicalize-type-list types auto-list))
  77           ((eq types :auto)
  78            auto-list)
  79           (t
  80            nil)))))
  81
  82 (defmethod database-initialize-database-type ((database-type (eql :mysql)))
  83   t)
  84
  85 (uffi:def-type mysql-mysql-ptr-def (* mysql-mysql))
  86 (uffi:def-type mysql-row-def mysql-row)
  87 (uffi:def-type mysql-mysql-res-ptr-def (* mysql-mysql-res))
  88
  89 (defclass mysql-database (database)
  90   ((mysql-ptr :accessor database-mysql-ptr :initarg :mysql-ptr
  91               :type mysql-mysql-ptr-def)))
  92
  93 (defmethod database-type ((database mysql-database))
  94   :mysql)
  95
  96 (defmethod database-name-from-spec (connection-spec (database-type (eql :mysql)))
  97   (check-connection-spec connection-spec database-type (host db user password))
  98   (destructuring-bind (host db user password) connection-spec
  99     (declare (ignore password))
 100     (concatenate 'string host "/" db "/" user)))
 101
 102 (defmethod database-connect (connection-spec (database-type (eql :mysql)))
 103   (check-connection-spec connection-spec database-type (host db user password))
 104   (destructuring-bind (host db user password) connection-spec
 105     (let ((mysql-ptr (mysql-init (uffi:make-null-pointer 'mysql-mysql)))
 106           (socket nil))
 107       (if (uffi:null-pointer-p mysql-ptr)
 108           (error 'clsql-connect-error
 109                  :database-type database-type
 110                  :connection-spec connection-spec
 111                  :errno (mysql-errno mysql-ptr)
 112                  :error (mysql-error-string mysql-ptr))
 113         (uffi:with-cstrings ((host-native host)
 114                             (user-native user)
 115                             (password-native password)
 116                             (db-native db)
 117                             (socket-native socket))
 118           (let ((error-occurred nil))
 119             (unwind-protect
 120                 (if (uffi:null-pointer-p
 121                      (mysql-real-connect
 122                       mysql-ptr host-native user-native password-native
 123                       db-native 0 socket-native 0))
 124                     (progn
 125                       (setq error-occurred t)
 126                       (error 'clsql-connect-error
 127                              :database-type database-type
 128                              :connection-spec connection-spec
 129                              :errno (mysql-errno mysql-ptr)
 130                              :error (mysql-error-string mysql-ptr)))
 131                   (make-instance 'mysql-database
 132                     :name (database-name-from-spec connection-spec
 133                                                    database-type)
 134                     :connection-spec connection-spec
 135                     :mysql-ptr mysql-ptr))
 136               (when error-occurred (mysql-close mysql-ptr)))))))))
 137
 138
 139 (defmethod database-disconnect ((database mysql-database))
 140   (mysql-close (database-mysql-ptr database))
 141   (setf (database-mysql-ptr database) nil)
 142   t)
 143
 144
 145 (defmethod database-query (query-expression (database mysql-database)
 146                            types)
 147   (with-slots (mysql-ptr) database
 148     (uffi:with-cstring (query-native query-expression)
 149        (if (zerop (mysql-query mysql-ptr query-native))
 150            (let ((res-ptr (mysql-use-result mysql-ptr)))
 151              (if res-ptr
 152                  (let ((num-fields (mysql-num-fields res-ptr)))
 153                    (setq types (canonicalize-types
 154                                       types num-fields
 155                                       res-ptr))
 156                    (unwind-protect
 157                        (loop for row = (mysql-fetch-row res-ptr)
 158                               until (uffi:null-pointer-p row)
 159                               collect
 160                               (loop for i from 0 below num-fields
 161                                     collect
 162                                     (convert-raw-field
 163                                      (uffi:deref-array row '(:array (* :unsigned-char)) i)
 164                                      types i)))
 165                      (mysql-free-result res-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          (error 'clsql-sql-error
 172                 :database database
 173                 :expression query-expression
 174                 :errno (mysql-errno mysql-ptr)
 175                 :error (mysql-error-string mysql-ptr))))))
 176
 177 (defmethod database-execute-command (sql-expression (database mysql-database))
 178   (uffi:with-cstring (sql-native sql-expression)
 179     (let ((mysql-ptr (database-mysql-ptr database)))
 180       (declare (type mysql-mysql-ptr-def mysql-ptr))
 181       (if (zerop (mysql-query mysql-ptr sql-native))
 182           t
 183         (error 'clsql-sql-error
 184                :database database
 185                :expression sql-expression
 186                :errno (mysql-errno mysql-ptr)
 187                :error (mysql-error-string mysql-ptr))))))
 188
 189 (defstruct mysql-result-set
 190   (res-ptr (uffi:make-null-pointer 'mysql-mysql-res)
 191            :type mysql-mysql-res-ptr-def)
 192   (types nil)
 193   (num-fields nil :type fixnum)
 194   (full-set nil :type boolean))
 195
 196
 197 (defmethod database-query-result-set (query-expression
 198                                       (database mysql-database)
 199                                       &key full-set types)
 200   (uffi:with-cstring (query-native query-expression)
 201     (let ((mysql-ptr (database-mysql-ptr database)))
 202      (declare (type mysql-mysql-ptr-def mysql-ptr))
 203       (if (zerop (mysql-query mysql-ptr query-native))
 204           (let ((res-ptr (if full-set
 205                              (mysql-store-result mysql-ptr)
 206                            (mysql-use-result mysql-ptr))))
 207             (declare (type mysql-mysql-res-ptr-def res-ptr))
 208             (if (not (uffi:null-pointer-p res-ptr))
 209                 (let* ((num-fields (mysql-num-fields res-ptr))
 210                        (result-set (make-mysql-result-set
 211                                     :res-ptr res-ptr
 212                                     :num-fields num-fields
 213                                     :full-set full-set
 214                                     :types
 215                                     (canonicalize-types
 216                                      types num-fields
 217                                      res-ptr))))
 218                   (if full-set
 219                       (values result-set
 220                               num-fields
 221                               (mysql-num-rows res-ptr))
 222                       (values result-set
 223                               num-fields)))
 224                 (error 'clsql-sql-error
 225                      :database database
 226                      :expression query-expression
 227                      :errno (mysql-errno mysql-ptr)
 228                      :error (mysql-error-string mysql-ptr))))
 229         (error 'clsql-sql-error
 230                :database database
 231                :expression query-expression
 232                :errno (mysql-errno mysql-ptr)
 233                :error (mysql-error-string mysql-ptr))))))
 234
 235 (defmethod database-dump-result-set (result-set (database mysql-database))
 236   (mysql-free-result (mysql-result-set-res-ptr result-set))
 237   t)
 238
 239
 240 (defmethod database-store-next-row (result-set (database mysql-database) list)
 241   (let* ((res-ptr (mysql-result-set-res-ptr result-set))
 242          (row (mysql-fetch-row res-ptr))
 243          (types (mysql-result-set-types result-set)))
 244     (declare (type mysql-mysql-res-ptr-def res-ptr)
 245              (type mysql-row-def row))
 246     (unless (uffi:null-pointer-p row)
 247       (loop for i from 0 below (mysql-result-set-num-fields result-set)
 248             for rest on list
 249             do
 250             (setf (car rest)
 251                   (convert-raw-field
 252                    (uffi:deref-array row '(:array (* :unsigned-char)) i)
 253                    types
 254                    i)))
 255       list)))
 256
 257
 258 (when (clsql-base-sys:database-type-library-loaded :mysql)
 259   (clsql-base-sys:initialize-database-type :database-type :mysql)
 260   (pushnew :mysql cl:*features*))