interfaces/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.8 2002/03/25 14:13:41 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-sys :mysql)
  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 canonicalize-field-types (types num-fields res-ptr)
  45   (cond
  46    ((if (listp types)
  47         (let ((length-types (length types))
  48               (new-types '()))
  49           (loop for i from 0 below num-fields
  50               do
  51                 (if (>= i length-types)
  52                     (push t new-types) ;; types is shorted than num-fields
  53                   (push
  54                    (case (nth i types)
  55                      ((:int :long :double t)
  56                       (nth i types))
  57                      (t
  58                       t))
  59                    new-types)))
  60           (nreverse new-types))))
  61    ((eq types :auto)
  62     (let ((new-types '())
  63           #+ignore (field-vec (mysql-fetch-fields res-ptr)))
  64       (dotimes (i num-fields)
  65         (declare (fixnum i))
  66         (let* ((field (mysql-fetch-field-direct res-ptr i))
  67                #+ignore
  68                (field-test (uffi:deref-array field-vec 'mysql-field-vector i))
  69                (type (uffi:get-slot-value field 'mysql-field 'type)))
  70           (push
  71            (case type
  72              ((#.mysql-field-types#tiny
  73                #.mysql-field-types#short
  74                #.mysql-field-types#int24
  75                #.mysql-field-types#long)
  76               :int)
  77              ((#.mysql-field-types#double
  78                #.mysql-field-types#float
  79                #.mysql-field-types#decimal)
  80               :double)
  81              (otherwise
  82               t))
  83            new-types)))
  84       (nreverse new-types)))
  85    (t
  86     nil)))
  87
  88 (uffi:def-function "atoi"
  89     ((str :cstring))
  90   :returning :int)
  91
  92 (uffi:def-function "atol"
  93     ((str :cstring))
  94   :returning :long)
  95
  96 (uffi:def-function "atof"
  97     ((str :cstring))
  98   :returning :double)
  99
 100 (defun convert-raw-field (char-ptr types index)
 101   (let ((type (if (listp types)
 102                   (nth index types)
 103                   types)))
 104     (case type
 105       (:int
 106        (atoi char-ptr))
 107       (:long
 108        (atol char-ptr))
 109       (:double
 110        (atof char-ptr))
 111       (otherwise
 112        (uffi:convert-from-foreign-string char-ptr)))))
 113
 114 (defmethod database-initialize-database-type ((database-type (eql :mysql)))
 115   t)
 116
 117 (uffi:def-type mysql-mysql-ptr-def (* mysql-mysql))
 118 (uffi:def-type mysql-row-def mysql-row)
 119 (uffi:def-type mysql-mysql-res-ptr-def (* mysql-mysql-res))
 120
 121 (defclass mysql-database (database)
 122   ((mysql-ptr :accessor database-mysql-ptr :initarg :mysql-ptr
 123               :type mysql-mysql-ptr-def)))
 124
 125 (defmethod database-name-from-spec (connection-spec (database-type (eql :mysql)))
 126   (check-connection-spec connection-spec database-type (host db user password))
 127   (destructuring-bind (host db user password) connection-spec
 128     (declare (ignore password))
 129     (concatenate 'string host "/" db "/" user)))
 130
 131
 132 (defmethod database-connect (connection-spec (database-type (eql :mysql)))
 133   (check-connection-spec connection-spec database-type (host db user password))
 134   (destructuring-bind (host db user password) connection-spec
 135     (let ((mysql-ptr (mysql-init (uffi:make-null-pointer 'mysql-mysql)))
 136           (socket nil))
 137       (if (uffi:null-pointer-p mysql-ptr)
 138           (error 'clsql-connect-error
 139                  :database-type database-type
 140                  :connection-spec connection-spec
 141                  :errno (mysql-errno mysql-ptr)
 142                  :error (mysql-error-string mysql-ptr))
 143         (uffi:with-cstrings ((host-native host)
 144                             (user-native user)
 145                             (password-native password)
 146                             (db-native db)
 147                             (socket-native socket))
 148           (let ((error-occurred nil))
 149             (unwind-protect
 150                 (if (uffi:null-pointer-p
 151                      (mysql-real-connect
 152                       mysql-ptr host-native user-native password-native
 153                       db-native 0 socket-native 0))
 154                     (progn
 155                       (setq error-occurred t)
 156                       (error 'clsql-connect-error
 157                              :database-type database-type
 158                              :connection-spec connection-spec
 159                              :errno (mysql-errno mysql-ptr)
 160                              :error (mysql-error-string mysql-ptr)))
 161                   (make-instance 'mysql-database
 162                     :name (database-name-from-spec connection-spec
 163                                                    database-type)
 164                     :mysql-ptr mysql-ptr))
 165               (when error-occurred (mysql-close mysql-ptr)))))))))
 166
 167
 168 (defmethod database-disconnect ((database mysql-database))
 169   (mysql-close (database-mysql-ptr database))
 170   (setf (database-mysql-ptr database) nil)
 171   t)
 172
 173
 174 (defmethod database-query (query-expression (database mysql-database)
 175                            field-types)
 176   (with-slots (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                  (let ((num-fields (mysql-num-fields res-ptr)))
 182                    (setq field-types (canonicalize-field-types
 183                                       field-types num-fields
 184                                       res-ptr))
 185                    (unwind-protect
 186                         (loop for row = (mysql-fetch-row res-ptr)
 187                               until (uffi:null-pointer-p row)
 188                               collect
 189                               (loop for i from 0 below num-fields
 190                                     collect
 191                                     (uffi:convert-from-foreign-string
 192                                      (uffi:deref-array row 'mysql-row i))))
 193                      (mysql-free-result res-ptr)))
 194                (error 'clsql-sql-error
 195                       :database database
 196                       :expression query-expression
 197                       :errno (mysql-errno mysql-ptr)
 198                       :error (mysql-error-string mysql-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
 205 (defmethod database-execute-command (sql-expression (database mysql-database))
 206   (uffi:with-cstring (sql-native sql-expression)
 207     (let ((mysql-ptr (database-mysql-ptr database)))
 208       (declare (type mysql-mysql-ptr-def mysql-ptr))
 209       (if (zerop (mysql-query mysql-ptr sql-native))
 210           t
 211         (error 'clsql-sql-error
 212                :database database
 213                :expression sql-expression
 214                :errno (mysql-errno mysql-ptr)
 215                :error (mysql-error-string mysql-ptr))))))
 216
 217 (defstruct mysql-result-set
 218   (res-ptr (uffi:make-null-pointer 'mysql-mysql-res)
 219            :type mysql-mysql-res-ptr-def)
 220   (field-types nil)
 221   (num-fields nil :type fixnum)
 222   (full-set nil :type boolean))
 223
 224
 225 (defmethod database-query-result-set (query-expression
 226                                       (database mysql-database)
 227                                       &key full-set field-types)
 228   (uffi:with-cstring (query-native query-expression)
 229     (let ((mysql-ptr (database-mysql-ptr database)))
 230      (declare (type mysql-mysql-ptr-def mysql-ptr))
 231       (if (zerop (mysql-query mysql-ptr query-native))
 232           (let ((res-ptr (if full-set
 233                              (mysql-store-result mysql-ptr)
 234                            (mysql-use-result mysql-ptr))))
 235             (declare (type mysql-mysql-res-ptr-def res-ptr))
 236             (if (not (uffi:null-pointer-p res-ptr))
 237                 (let* ((num-fields (mysql-num-fields res-ptr))
 238                        (result-set (make-mysql-result-set
 239                                     :res-ptr res-ptr
 240                                     :num-fields num-fields
 241                                     :full-set full-set
 242                                     :field-types
 243                                     (canonicalize-field-types
 244                                      field-types num-fields
 245                                      res-ptr))))
 246                   (if full-set
 247                       (values result-set
 248                               num-fields
 249                               (mysql-num-rows res-ptr))
 250                       (values result-set
 251                               num-fields)))
 252                 (error 'clsql-sql-error
 253                      :database database
 254                      :expression query-expression
 255                      :errno (mysql-errno mysql-ptr)
 256                      :error (mysql-error-string mysql-ptr))))
 257         (error 'clsql-sql-error
 258                :database database
 259                :expression query-expression
 260                :errno (mysql-errno mysql-ptr)
 261                :error (mysql-error-string mysql-ptr))))))
 262
 263 (defmethod database-dump-result-set (result-set (database mysql-database))
 264   (mysql-free-result (mysql-result-set-res-ptr result-set))
 265   t)
 266
 267
 268
 269 (defmethod database-store-next-row (result-set (database mysql-database) list)
 270   (let* ((res-ptr (mysql-result-set-res-ptr result-set))
 271          (row (mysql-fetch-row res-ptr))
 272          (field-types (mysql-result-set-field-types result-set)))
 273     (declare (type mysql-mysql-res-ptr-def res-ptr)
 274              (type mysql-row-def row))
 275     (unless (uffi:null-pointer-p row)
 276       (loop for i from 0 below (mysql-result-set-num-fields result-set)
 277             for rest on list
 278             do
 279             (setf (car rest)
 280                   (convert-raw-field
 281                    (uffi:deref-array row 'mysql-row i)
 282                    field-types
 283                    i)))
 284       list)))
 285
 286