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.6 2002/03/24 22:25:51 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 (defmethod database-initialize-database-type ((database-type (eql :mysql)))
  43   t)
  44
  45 (uffi:def-type mysql-mysql-ptr-def (* mysql-mysql))
  46 (uffi:def-type mysql-row-def mysql-row)
  47 (uffi:def-type mysql-mysql-res-ptr-def (* mysql-mysql-res))
  48
  49 (defclass mysql-database (database)
  50   ((mysql-ptr :accessor database-mysql-ptr :initarg :mysql-ptr
  51               :type mysql-mysql-ptr-def)))
  52
  53 (defmethod database-name-from-spec (connection-spec (database-type (eql :mysql)))
  54   (check-connection-spec connection-spec database-type (host db user password))
  55   (destructuring-bind (host db user password) connection-spec
  56     (declare (ignore password))
  57     (concatenate 'string host "/" db "/" user)))
  58
  59 (defmethod database-connect (connection-spec (database-type (eql :mysql)))
  60   (check-connection-spec connection-spec database-type (host db user password))
  61   (destructuring-bind (host db user password) connection-spec
  62     (let ((mysql-ptr (mysql-init (uffi:make-null-pointer 'mysql-mysql)))
  63           (socket nil))
  64       (if (uffi:null-pointer-p mysql-ptr)
  65           (error 'clsql-connect-error
  66                  :database-type database-type
  67                  :connection-spec connection-spec
  68                  :errno (mysql-errno mysql-ptr)
  69                  :error (mysql-error-string mysql-ptr))
  70         (uffi:with-cstrings ((host-native host)
  71                             (user-native user)
  72                             (password-native password)
  73                             (db-native db)
  74                             (socket-native socket))
  75           (let ((error-occurred nil))
  76             (unwind-protect
  77                 (if (uffi:null-pointer-p
  78                      (mysql-real-connect
  79                       mysql-ptr host-native user-native password-native
  80                       db-native 0 socket-native 0))
  81                     (progn
  82                       (setq error-occurred t)
  83                       (error 'clsql-connect-error
  84                              :database-type database-type
  85                              :connection-spec connection-spec
  86                              :errno (mysql-errno mysql-ptr)
  87                              :error (mysql-error-string mysql-ptr)))
  88                   (make-instance 'mysql-database
  89                     :name (database-name-from-spec connection-spec
  90                                                    database-type)
  91                     :mysql-ptr mysql-ptr))
  92               (when error-occurred (mysql-close mysql-ptr)))))))))
  93
  94
  95 (defmethod database-disconnect ((database mysql-database))
  96   (mysql-close (database-mysql-ptr database))
  97   (setf (database-mysql-ptr database) nil)
  98   t)
  99
 100
 101 (defstruct mysql-result-set
 102   (res-ptr (uffi:make-null-pointer 'mysql-mysql-res)
 103            :type mysql-mysql-res-ptr-def)
 104   (field-types nil)
 105   (full-set nil :type boolean))
 106
 107 (defmethod database-dump-result-set (result-set (database mysql-database))
 108   (mysql-free-result (mysql-result-set-res-ptr result-set))
 109   t)
 110
 111
 112 (defmethod database-store-next-row (result-set (database mysql-database) list)
 113   (let* ((res-ptr (mysql-result-set-res-ptr result-set))
 114          (row (mysql-fetch-row res-ptr)))
 115     (declare (type mysql-mysql-res-ptr-def res-ptr)
 116              (type mysql-row-def row))
 117     (unless (uffi:null-pointer-p row)
 118       (loop for i from 0 below (mysql-num-fields res-ptr)
 119           for rest on list
 120           do
 121             (setf (car rest)
 122               (uffi:convert-from-foreign-string (uffi:deref-array row 'mysql-row i))))
 123       list)))
 124
 125
 126 (defmethod database-execute-command (sql-expression (database mysql-database))
 127   (uffi:with-cstring (sql-native sql-expression)
 128     (let ((mysql-ptr (database-mysql-ptr database)))
 129       (declare (type mysql-mysql-ptr-def mysql-ptr))
 130       (if (zerop (mysql-query mysql-ptr sql-native))
 131           t
 132         (error 'clsql-sql-error
 133                :database database
 134                :expression sql-expression
 135                :errno (mysql-errno mysql-ptr)
 136                :error (mysql-error-string mysql-ptr))))))
 137
 138
 139
 140 (defmethod database-query (query-expression (database mysql-database)
 141                            field-types)
 142   (with-slots (mysql-ptr) database
 143     (uffi:with-cstring (query-native query-expression)
 144        (if (zerop (mysql-query mysql-ptr query-native))
 145            (let ((res-ptr (mysql-use-result mysql-ptr)))
 146              (if res-ptr
 147                  (unwind-protect
 148                      (loop for row = (mysql-fetch-row res-ptr)
 149                          until (uffi:null-pointer-p row)
 150                          collect
 151                            (loop for i from 0 below (mysql-num-fields res-ptr)
 152                                collect
 153                                  (uffi:convert-from-foreign-string
 154                                   (uffi:deref-array row 'mysql-row i))))
 155                    (mysql-free-result res-ptr))
 156                (error 'clsql-sql-error
 157                       :database database
 158                       :expression query-expression
 159                       :errno (mysql-errno mysql-ptr)
 160                       :error (mysql-error-string mysql-ptr))))
 161          (error 'clsql-sql-error
 162                 :database database
 163                 :expression query-expression
 164                 :errno (mysql-errno mysql-ptr)
 165                 :error (mysql-error-string mysql-ptr))))))
 166
 167
 168 (defmethod database-query-result-set (query-expression (database mysql-database)
 169                                       &key full-set field-types)
 170   (uffi:with-cstring (query-native query-expression)
 171     (let ((mysql-ptr (database-mysql-ptr database)))
 172      (declare (type mysql-mysql-ptr-def mysql-ptr))
 173       (if (zerop (mysql-query mysql-ptr query-native))
 174           (let ((res-ptr (if full-set
 175                              (mysql-store-result mysql-ptr)
 176                            (mysql-use-result mysql-ptr))))
 177             (declare (type mysql-mysql-res-ptr-def res-ptr))
 178             (if (not (uffi:null-pointer-p res-ptr))
 179                 (if full-set
 180                     (values (make-mysql-result-set :res-ptr res-ptr :full-set t
 181                                                    :field-types field-types)
 182                             (mysql-num-fields res-ptr)
 183                             (mysql-num-rows res-ptr))
 184                   (values (make-mysql-result-set :res-ptr res-ptr)
 185                           (mysql-num-fields res-ptr)))
 186               (error 'clsql-sql-error
 187                      :database database
 188                      :expression query-expression
 189                      :errno (mysql-errno mysql-ptr)
 190                      :error (mysql-error-string mysql-ptr))))
 191         (error 'clsql-sql-error
 192                :database database
 193                :expression query-expression
 194                :errno (mysql-errno mysql-ptr)
 195                :error (mysql-error-string mysql-ptr))))))
 196
 197