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