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