1; mysql.ss - DBD (Database Driver) for MySQL
2;
3;   Copyright (c) 2009  Higepon(Taro Minowa)  <higepon@users.sourceforge.jp>
4;
5;   Redistribution and use in source and binary forms, with or without
6;   modification, are permitted provided that the following conditions
7;   are met:
8;
9;   1. Redistributions of source code must retain the above copyright
10;      notice, this list of conditions and the following disclaimer.
11;
12;   2. Redistributions in binary form must reproduce the above copyright
13;      notice, this list of conditions and the following disclaimer in the
14;      documentation and/or other materials provided with the distribution.
15;
16;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
17;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
18;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
19;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
20;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
21;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
22;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
23;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
24;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
25;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
26;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
27;
28;  $Id: dbi.ss 621 2008-11-09 06:22:47Z higepon $
29
30(library (mosh dbd mysql)
31  (export <dbd-mysql>)
32  (import
33   (mosh mysql)
34   (clos user)
35   (clos core)
36   (only (mosh) format)
37   (only (mosh ffi) pointer-null? pointer->integer string->utf8z)
38   (only (rnrs) define quote let unless when assertion-violation zero?
39                guard cond else => lambda values string->number raise
40                let-values and = display reverse cons vector-set! current-error-port unquote
41                vector-ref make-vector vector-length + let* equal? string->utf8
42                make-hashtable string-hash hashtable-set! hashtable-ref quasiquote
43                string-downcase)
44   (mosh dbi))
45
46(define-class <dbd-mysql> (<dbd>))
47(define-class <mysql-connection> (<connection>) mysql)
48(define-class <mysql-result> (<result>) mysql lst getter)
49
50(define (vector-for-each-with-index proc v)
51  (let ([len (vector-length v)])
52    (let loop ([i 0])
53      (cond
54       [(= i len) v]
55       [else
56        (proc (vector-ref v i) i)
57        (loop (+ i 1))]))))
58
59(define (make-getter mysql result)
60  (let* ([field-count (mysql-field-count mysql)]
61         [ht (make-hashtable string-hash equal?)])
62    (let loop ([i 0])
63      (cond
64       [(= field-count i) '()]
65       [else
66        ;; ignore case
67        (hashtable-set! ht (string-downcase (mysql-field-name (mysql-fetch-field-direct result i))) i)
68        (loop (+ i 1))]))
69    (lambda (row name)
70      (let ([index (hashtable-ref ht (string-downcase name) #f)])
71        (unless index
72          (assertion-violation 'dbi-getter "unknown column" name))
73      (vector-ref row index)))))
74
75(define-method initialize ((m <mysql-connection>) init-args)
76  (initialize-direct-slots m <mysql-connection> init-args))
77
78(define-method initialize ((m <mysql-result>) init-args)
79  (initialize-direct-slots m <mysql-result> init-args))
80
81(define-method dbi-result->list ((res <mysql-result>))
82  (slot-ref res 'lst))
83
84(define-method dbi-close ((conn <mysql-connection>))
85  (mysql-close (slot-ref conn 'mysql)))
86
87(define-method dbi-getter ((res <mysql-result>))
88  (slot-ref res 'getter))
89
90(define-method dbd-execute ((conn <mysql-connection>) sql)
91  (let ([mysql (slot-ref conn 'mysql)])
92    ;; we assume mysql-server accepts utf8
93    (unless (zero? (mysql-query mysql (string->utf8z sql))) ;; null terminated c char*.
94      (raise (make-dbi-error 'mysql-query sql (mysql-error mysql) (mysql-sqlstate mysql))))
95    (let ([result (mysql-store-result mysql)])
96      (cond
97       ;; insert, update, create table
98       [(pointer-null? result)
99        (make <mysql-result>
100          'mysql mysql
101          'lst '()
102          'getter (lambda a `(insert-id . ,(pointer->integer (mysql-insert-id mysql)))))]
103       ;; select
104       [else
105        (let loop ([row (mysql-fetch-row result)]
106                   [ret '()])
107          (cond
108           [(pointer-null? row)
109            (let ([getter (make-getter mysql result)])
110              (mysql-free-result result)
111              (make <mysql-result>
112                'mysql mysql
113                'lst (reverse ret)
114                'getter getter))]
115           [else
116            (let ([v (make-vector (mysql-field-count mysql))])
117              (vector-for-each-with-index
118               (lambda (val index)
119                 (vector-set! v index (mysql-row-ref result row index)))
120               v)
121              (loop (mysql-fetch-row result) (cons v ret)))]))]))))
122
123(define-method dbd-connect ((dbd <dbd-mysql>) user password options)
124  (define (parse-options options)
125    (cond
126     [(#/([^:]+):([^:]+):(\d+)/ options) =>
127      (lambda (m)
128        (values (m 1) (m 2) (string->number (m 3))))]
129     [else
130      (values #f #f #f)]))
131  (let ([mysql (guard (c (#t #f)) (mysql-init))])
132    (unless mysql
133      (assertion-violation 'mysql-init "mysql-init failed"))
134    (let-values ([(db host port) (parse-options options)])
135      (cond
136       [(and db host port)
137        (when (pointer-null? (mysql-real-connect mysql host user password db port NULL 0))
138          (assertion-violation 'dbd-connect "mysql connection failed" (mysql-error mysql)))
139        (make <mysql-connection> 'mysql mysql)]
140       [else
141        (assertion-violation 'dbd-connect "invalid options in dsn" options)]))))
142
143)
144