1;;; 2;;; dbi - common database interface layer 3;;; 4;;; Copyright (c) 2003-2005 Scheme Arts, L.L.C., All rights reserved. 5;;; Copyright (c) 2003-2005 Time Intermedia Corporation, All rights reserved. 6;;; 7;;; Redistribution and use in source and binary forms, with or without 8;;; modification, are permitted provided that the following conditions 9;;; are met: 10;;; 11;;; 1. Redistributions of source code must retain the above copyright 12;;; notice, this list of conditions and the following disclaimer. 13;;; 14;;; 2. Redistributions in binary form must reproduce the above copyright 15;;; notice, this list of conditions and the following disclaimer in the 16;;; documentation and/or other materials provided with the distribution. 17;;; 18;;; 3. Neither the name of the authors nor the names of its contributors 19;;; may be used to endorse or promote products derived from this 20;;; software without specific prior written permission. 21;;; 22;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 23;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 24;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 25;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 26;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 27;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 28;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 29;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 30;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 31;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 32;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 33;;; 34 35(define-module dbi 36 (use text.sql) 37 (use file.util) 38 (use srfi-1) 39 (use srfi-13) 40 (use util.match) 41 (extend util.relation) 42 (export <dbi-error> <dbi-nonexistent-driver-error> 43 <dbi-unsupported-error> <dbi-parameter-error> 44 <dbi-driver> <dbi-connection> <dbi-query> 45 dbi-connect dbi-close dbi-prepare dbi-execute dbi-do 46 dbi-open? dbi-parse-dsn dbi-make-driver 47 dbi-prepare-sql dbi-escape-sql dbi-list-drivers 48 dbi-make-connection dbi-execute-using-connection 49 ;; compatibility 50 dbi-make-query dbi-execute-query dbi-get-value 51 <dbi-exception> <dbi-result-set>)) 52(select-module dbi) 53 54;;;============================================================== 55;;; DBI conditions 56;;; 57 58;; Root of dbi-related errors 59(define-condition-type <dbi-error> <error> #f) 60 61;; Failed to load the specified driver 62(define-condition-type <dbi-nonexistent-driver-error> <dbi-error> #f 63 (driver-name)) 64 65;; Feature not supported 66(define-condition-type <dbi-unsupported-error> <dbi-error> #f) 67 68;; Parameter mismatch between a prepared query and its execution. 69(define-condition-type <dbi-parameter-error> <dbi-error> #f) 70 71 72;;;============================================================== 73;;; DBI object definitions 74;;; 75 76;; <dbi-driver> is the base class of database drivers; a database 77;; driver implements actual interface to a specific database system. 78;; Each dbd.* module provides the concrete implementation. 79;; 80;; Usually the singleton instance of a concrete driver is created 81;; implicitly by dbi-connect with the data-source string. So the 82;; user hardly need to see <dbi-driver> object. 83 84(define-class <dbi-driver> () 85 ((driver-name :init-keyword :driver-name) ; "mysql" "pg" etc. 86 )) 87 88;; <dbi-connection> : represents a connection to the database system. 89;; All the transactions must be done while the connection is 'open'. 90(define-class <dbi-connection> () 91 ((open :init-value #t) ;; this slot is for backward compatibility. 92 ;; do not count on this. will be removed. 93 )) 94 95;; <dbi-query> : represents a prepared query. 96(define-class <dbi-query> () 97 ((connection :init-keyword :connection) 98 (prepared :init-keyword :prepared) 99 (open :init-value #t) ;; this slot is for backward compatibility. 100 ;; do not count on this. will be removed. 101 )) 102 103;;;============================================================== 104;;; User-level APIs 105;;; 106 107;; Establish a connection to the data source specified by DSN, 108;; and returns a connection object. 109;; DSN is the data source name, which can have the following syntax. 110;; "dbi:driver-type" 111;; "dbi:driver-type:connection-options" 112;; Connection-options is like "name1=value1;name2=value2;...". 113;; 114(define (dbi-connect dsn . args) 115 (receive (driver-name options option-alist) (dbi-parse-dsn dsn) 116 (apply dbi-make-connection 117 (dbi-make-driver driver-name) options option-alist args))) 118 119;; Prepares SQL statement and returns a closure, which executes 120;; the statement when called. If the given SQL statement takes parameters, 121;; the closure takes the same number of arguments as of the parameters. 122;; 123;; The default method uses text.sql to parse the SQL statement, and calls 124;; legacy dbd API. This will go away once the drivers switched to the 125;; new dbd API. 126(define-method dbi-prepare ((c <dbi-connection>) (sql <string>) 127 :key (pass-through #f)) 128 (let1 prepared (if pass-through 129 (^ args 130 (unless (null? args) 131 (error <dbi-parameter-error> 132 "parameter is given to the pass through sql:" sql)) 133 sql) 134 (dbi-prepare-sql c sql)) 135 (make <dbi-query> :connection c :prepared prepared))) 136 137(define-method dbi-execute ((q <dbi-query>) . params) 138 (dbi-execute-using-connection (ref q 'connection) q params)) 139 140(define-method dbi-execute-using-connection ((c <dbi-connection>) 141 (q <dbi-query>) params) 142 (dbi-execute-query c (apply (ref q 'prepared) params))) 143 144;; Does preparation and execution at once. The driver may overload this. 145(define-method dbi-do ((c <dbi-connection>) sql options . args) 146 (unless (proper-list? options) 147 (error "dbi-do: bad option list:" options)) 148 (apply dbi-execute (apply dbi-prepare c sql options) args)) 149 150(define-method dbi-do ((c <dbi-connection>) sql) 151 (dbi-do c sql '())) 152 153;; Returns a string safe to be embedded in SQL. 154;; (dbi-escape-sql c "Don't know") => "'Don''t know'" 155;; What's "safe" depends on the underlying DBMS. The default procedure 156;; only escapes a single quote by repeating it. If the DBMS has other 157;; type of escaping mechanism, the driver should overload this with 158;; a proper escaping method. 159(define-method dbi-escape-sql ((c <dbi-connection>) str) 160 (regexp-replace-all #/'/ str "''")) 161 162;; Returns a list of available dbd.* backends. Each entry is 163;; a cons of a module name and its driver name. 164(define (dbi-list-drivers) 165 (library-map 'dbd.* (^[m p] m))) 166 167;;;============================================================== 168;;; DBD-level APIs 169;;; 170 171;; Subclass SHOULD implement this. 172(define-method dbi-make-connection ((d <dbi-driver>) 173 (options <string>) 174 (option-alist <list>) 175 :key (username "") (password "")) 176 ;; The default method here is just a temporary one to use 177 ;; older dbd drivers. Will go away once the drivers catch up 178 ;; the new interface. 179 ;; Calls deprecated dbi-make-connection API. 180 (dbi-make-connection d username password (or options ""))) 181 182;; Usually the subclass should define these for the connection 183;; and result set objects. 184(define-method dbi-open? (obj) #t) 185(define-method dbi-close (obj) (undefined)) 186 187;;;=================================================================== 188;;; Low-level utilities 189;;; 190 191;; Parse data source name. Returns 192;; (driver-name, option-string, option-alist) 193;; 194(define (dbi-parse-dsn data-source-name) 195 (rxmatch-case data-source-name 196 (#/^dbi:([\w-]+)(?::(.*))?$/ (#f driver options) 197 (if (and options (not (string-null? options))) 198 (let1 alist (map (^[nv] (receive (n v) (string-scan nv "=" 'both) 199 (if n (cons n v) (cons nv #t)))) 200 (string-split options #\;)) 201 (values driver options alist)) 202 (values driver "" '()))) 203 (else (error <dbi-error> "bad data source name spec:" data-source-name)))) 204 205;; Loads a concrete driver module, and returns an instance of 206;; the driver. 207(define (dbi-make-driver driver-name) 208 (let* ([module (string->symbol #"dbd.~driver-name")] 209 [path (module-name->path module)] 210 [class-name (string->symbol #"<~|driver-name|-driver>")]) 211 (or (and-let* ([ (library-exists? path :strict? #t) ] 212 [driver-class 213 (begin (eval `(require ,(path-sans-extension path)) 214 (current-module)) 215 (global-variable-ref module class-name #f))]) 216 (make driver-class :driver-name driver-name)) 217 (errorf <dbi-nonexistent-driver-error> 218 :driver-name driver-name 219 "couldn't load driver dbd.~a" driver-name)))) 220 221;; Default prepared-SQL handler 222;; dbi-prepare-sql returns a procedure, which generates a complete sql 223;; when called with binding values to the parameters. 224(define (dbi-prepare-sql conn sql) 225 (let* ([tokens (sql-tokenize sql)] 226 [num-params (count (^[elt] 227 (match elt 228 [('parameter (? integer?)) #t] 229 [('parameter (? string? name)) 230 (errorf <dbi-unsupported-error> 231 "Named parameter (:~a) isn't supported yet" name)] 232 [else #f])) 233 tokens)]) 234 (^ args 235 (unless (= (length args) num-params) 236 (error <dbi-parameter-error> 237 "wrong number of parameters given to an SQL:" sql)) 238 (call-with-output-string 239 (^p (with-port-locking p 240 (cut generate-sql/parameters conn tokens args p sql))))))) 241 242(define (generate-sql/parameters conn tokens args p sql) 243 (let loop ([tokens tokens] 244 [args args] 245 [delim #t]) 246 (unless (null? tokens) 247 (match (car tokens) 248 [(? char? x) 249 (display x p) 250 (loop (cdr tokens) args #t)] 251 [(? symbol? x) 252 (unless delim (write-char #\space p)) 253 (display x p) 254 (loop (cdr tokens) args #f)] 255 [(? string? x) 256 (unless delim (write-char #\space p)) 257 (display x p) 258 (loop (cdr tokens) args #f)] 259 [('delimited x) 260 (unless delim (write-char #\space p)) 261 (format p "\"~a\"" (regexp-replace-all #/\"/ x "\"\"")) 262 (loop (cdr tokens) args #f)] 263 [('string x) 264 (unless delim (write-char #\space p)) 265 (format p "'~a'" (regexp-replace-all #/'/ x "''")) 266 (loop (cdr tokens) args #f)] 267 [('number x) 268 (unless delim (write-char #\space p)) 269 (display x p) 270 (loop (cdr tokens) args #f)] 271 [('parameter n) 272 (unless delim (write-char #\space p)) 273 (let* ([argval (car args)] 274 [s (cond 275 [(not argval) "NULL"] 276 [(string? argval) 277 #"'~(dbi-escape-sql conn argval)'"] 278 [(symbol? argval) 279 #"'~(dbi-escape-sql conn (symbol->string argval))'"] 280 [(real? argval) (number->string argval)] 281 [else (error <dbi-parameter-error> 282 "bad type of parameter for SQL:" argval)])]) 283 (display s p)) 284 (loop (cdr tokens) (cdr args) #f)] 285 [('bitstring x) 286 (unless delim (write-char #\space p)) 287 (format p "B'~a'" x) 288 (loop (cdr tokens) args #f)] 289 [('hexstring x) 290 (unless delim (write-char #\space p)) 291 (format p "X'~a'" x) 292 (loop (cdr tokens) args #f)] 293 [else 294 (errorf <dbi-unsupported-error> 295 "unsupported SQL token ~a in ~s" (car tokens) sql)] 296 )))) 297 298 299;;;============================================================== 300;;; Backward compatibility stuff 301;;; 302 303;; These are provided for compatibility with dbi-0.1.5 and dbd-* 304;; modules that depend on it. The newly written code shouldn't use 305;; these interface. Will be gone in a few releases. 306 307(define <dbi-exception> <dbi-error>) 308 309(define-class <dbi-result-set> () 310 ((open :init-value #t))) 311 312(define-method dbi-get-value ((r <sequence>) (n <integer>)) 313 (ref r n)) 314 315;; Older API 316(define-method dbi-make-connection ((d <dbi-driver>) 317 (user <string>) 318 (pass <string>) 319 (options <string>)) 320 (dbi-connect #"dbi:~(slot-ref d 'driver-name):~options" 321 :username user :password pass)) 322(define-method dbi-make-query ((c <dbi-connection>) . _) 323 (make <dbi-query> :connection c)) 324(define-method dbi-execute-query ((q <dbi-query>) (s <string>)) 325 (dbi-do (ref q 'connection) s '(:pass-through #t))) 326 327