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