sqlite3.scm (18420B)
1 ;; Guile-SQLite3 2 ;; Copyright (C) 2010, 2014 Andy Wingo <wingo at pobox dot com> 3 ;; Copyright (C) 2018 Ludovic Courtès <ludo@gnu.org> 4 (define-module (sqlite3) 5 #:export (sqlite-open 6 sqlite-db? 7 sqlite-close 8 9 sqlite-enable-load-extension 10 sqlite-exec 11 sqlite-prepare 12 sqlite-bind 13 sqlite-bind-arguments 14 sqlite-column-names 15 sqlite-step 16 sqlite-fold 17 sqlite-fold-right 18 sqlite-map 19 sqlite-reset 20 sqlite-finalize 21 sqlite-bind-parameter-index 22 sqlite-busy-timeout 23 sqlite-expanded-sql 24 sqlite-trace 25 26 SQLITE_OPEN_READONLY 27 SQLITE_OPEN_READWRITE 28 SQLITE_OPEN_CREATE 29 SQLITE_OPEN_DELETEONCLOSE 30 SQLITE_OPEN_EXCLUSIVE 31 SQLITE_OPEN_MAIN_DB 32 SQLITE_OPEN_TEMP_DB 33 SQLITE_OPEN_TRANSIENT_DB 34 SQLITE_OPEN_MAIN_JOURNAL 35 SQLITE_OPEN_TEMP_JOURNAL 36 SQLITE_OPEN_SUBJOURNAL 37 SQLITE_OPEN_MASTER_JOURNAL 38 SQLITE_OPEN_NOMUTEX 39 SQLITE_OPEN_FULLMUTEX 40 SQLITE_OPEN_SHAREDCACHE 41 SQLITE_OPEN_PRIVATECACHE 42 SQLITE_OPEN_URI 43 44 SQLITE_TRACE_STMT 45 SQLITE_TRACE_PROFILE 46 SQLITE_TRACE_ROW 47 SQLITE_TRACE_CLOSE 48 49 SQLITE_CONSTRAINT 50 SQLITE_CONSTRAINT_PRIMARYKEY 51 SQLITE_CONSTRAINT_UNIQUE)) 52 (use-modules 53 (system foreign) 54 (rnrs bytevectors) 55 (ice-9 match) 56 (srfi srfi-1) 57 (srfi srfi-9) 58 (srfi srfi-19)) 59 60 (define (string->utf8-pointer s) 61 (string->pointer s "utf-8")) 62 63 (define (utf8-pointer->string p) 64 (pointer->string p -1 "utf-8")) 65 66 (define SQLITE_OPEN_READONLY #x00000001) 67 (define SQLITE_OPEN_READWRITE #x00000002) 68 (define SQLITE_OPEN_CREATE #x00000004) 69 (define SQLITE_OPEN_DELETEONCLOSE #x00000008) 70 (define SQLITE_OPEN_EXCLUSIVE #x00000010) 71 (define SQLITE_OPEN_MAIN_DB #x00000100) 72 (define SQLITE_OPEN_TEMP_DB #x00000200) 73 (define SQLITE_OPEN_TRANSIENT_DB #x00000400) 74 (define SQLITE_OPEN_MAIN_JOURNAL #x00000800) 75 (define SQLITE_OPEN_TEMP_JOURNAL #x00001000) 76 (define SQLITE_OPEN_SUBJOURNAL #x00002000) 77 (define SQLITE_OPEN_MASTER_JOURNAL #x00004000) 78 (define SQLITE_OPEN_NOMUTEX #x00008000) 79 (define SQLITE_OPEN_FULLMUTEX #x00010000) 80 (define SQLITE_OPEN_SHAREDCACHE #x00020000) 81 (define SQLITE_OPEN_PRIVATECACHE #x00040000) 82 (define SQLITE_OPEN_URI #x00000040) 83 84 (define SQLITE_TRACE_STMT #x00000001) 85 (define SQLITE_TRACE_PROFILE #x00000002) 86 (define SQLITE_TRACE_ROW #x00000004) 87 (define SQLITE_TRACE_CLOSE #x00000008) 88 89 (define SQLITE_CONSTRAINT 19) 90 (define SQLITE_CONSTRAINT_PRIMARYKEY 91 (logior SQLITE_CONSTRAINT (ash 6 8))) 92 (define SQLITE_CONSTRAINT_UNIQUE 93 (logior SQLITE_CONSTRAINT (ash 8 8))) 94 95 (define libsqlite3 (dynamic-link "libsqlite3")) 96 97 (define-record-type <sqlite-db> 98 (make-db pointer open? stmts) 99 db? 100 (pointer db-pointer) 101 (open? db-open? set-db-open?!) 102 (stmts db-stmts)) 103 104 (define-syntax sqlite-db? 105 (identifier-syntax db?)) 106 107 (define-record-type <sqlite-stmt> 108 (make-stmt pointer live? reset? cached?) 109 stmt? 110 (pointer stmt-pointer) 111 (live? stmt-live? set-stmt-live?!) 112 (reset? stmt-reset? set-stmt-reset?!) 113 (cached? stmt-cached? set-stmt-cached?!)) 114 115 (define sqlite-errmsg 116 (let ((f (pointer->procedure 117 '* 118 (dynamic-func "sqlite3_errmsg" libsqlite3) 119 (list '*)))) 120 (lambda (db) 121 (utf8-pointer->string (f (db-pointer db)))))) 122 123 (define sqlite-errcode 124 (let ((f (pointer->procedure 125 int 126 (dynamic-func "sqlite3_extended_errcode" libsqlite3) 127 (list '*)))) 128 (lambda (db) 129 (f (db-pointer db))))) 130 131 (define* (sqlite-error db who #:optional code 132 (errmsg (and db (sqlite-errmsg db)))) 133 (throw 'sqlite-error who code errmsg)) 134 135 (define* (check-error db #:optional who) 136 (let ((code (sqlite-errcode db))) 137 (if (not (zero? code)) 138 (sqlite-error db who code)))) 139 140 (define sqlite-close 141 (let ((f (pointer->procedure 142 int 143 (dynamic-func "sqlite3_close" libsqlite3) 144 (list '*)))) 145 (lambda (db) 146 (when (db-open? db) 147 (hash-for-each (lambda (sql stmt) 148 (set-stmt-cached?! stmt #f) 149 (sqlite-finalize stmt)) 150 (db-stmts db)) 151 (hash-clear! (db-stmts db)) 152 153 (let ((p (db-pointer db))) 154 (set-db-open?! db #f) 155 (f p)))))) 156 157 (define db-guardian (make-guardian)) 158 (define (pump-db-guardian) 159 (let ((db (db-guardian))) 160 (if db 161 (begin 162 (sqlite-close db) 163 (pump-db-guardian))))) 164 (add-hook! after-gc-hook pump-db-guardian) 165 166 (define (static-errcode->errmsg code) 167 (case code 168 ((1) "SQL error or missing database") 169 ((2) "Internal logic error in SQLite") 170 ((3) "Access permission denied") 171 ((5) "The database file is locked") 172 ((6) "A table in the database is locked") 173 ((7) "A malloc() failed") 174 ((8) "Attempt to write a readonly database") 175 ((10) "Some kind of disk I/O error occurred") 176 ((11) "The database disk image is malformed") 177 ((14) "Unable to open the database file") 178 ((21) "Library used incorrectly") 179 ((22) "Uses OS features not supported on host") 180 ((23) "Authorization denied") 181 ((24) "Auxiliary database format error") 182 ((26) "File opened that is not a database file") 183 (else "Unknown error"))) 184 185 (define sqlite-open 186 (let ((f (pointer->procedure 187 int 188 (dynamic-func "sqlite3_open_v2" libsqlite3) 189 (list '* '* int '*)))) 190 (lambda* (filename #:optional 191 (flags (logior SQLITE_OPEN_READWRITE 192 SQLITE_OPEN_CREATE 193 SQLITE_OPEN_URI)) 194 (vfs #f)) 195 (let* ((out-db (bytevector->pointer (make-bytevector (sizeof '*) 0))) 196 (ret (f (string->utf8-pointer filename) 197 out-db 198 flags 199 (if vfs (string->utf8-pointer vfs) %null-pointer)))) 200 (if (zero? ret) 201 (let ((db (make-db (dereference-pointer out-db) #t 202 (make-hash-table)))) 203 (db-guardian db) 204 db) 205 (sqlite-error #f 'sqlite-open ret (static-errcode->errmsg ret))))))) 206 207 (define sqlite-exec 208 (let ((exec (pointer->procedure 209 int 210 (dynamic-func "sqlite3_exec" (@@ (sqlite3) libsqlite3)) 211 '(* * * * *)))) 212 (lambda* (db sql) 213 "Evaluate the string SQL, which may contain one or several SQL 214 statements, into DB. The result is unspecified." 215 (assert-live-db! db) 216 (unless (zero? (exec (db-pointer db) (string->pointer sql) 217 %null-pointer %null-pointer %null-pointer)) 218 (check-error db 'sqlite-exec))))) 219 220 (define sqlite-remove-statement! 221 (lambda (db stmt) 222 (when (stmt-cached? stmt) 223 (let* ((stmts (db-stmts db)) 224 (key (catch 'value 225 (lambda () 226 (hash-for-each (lambda (key value) 227 (when (eq? value stmt) 228 (throw 'value key))) 229 stmts) 230 #f) 231 (lambda (_ key) key)))) 232 (hash-remove! stmts key))))) 233 234 (define sqlite-finalize 235 (let ((f (pointer->procedure 236 int 237 (dynamic-func "sqlite3_finalize" libsqlite3) 238 (list '*)))) 239 (lambda (stmt) 240 (when (stmt-live? stmt) 241 (if (stmt-cached? stmt) 242 (sqlite-reset stmt) 243 (let ((p (stmt-pointer stmt))) 244 (sqlite-remove-statement! (stmt->db stmt) stmt) 245 (set-stmt-live?! stmt #f) 246 (f p))))))) 247 248 (define *stmt-map* (make-weak-key-hash-table)) 249 (define (stmt->db stmt) 250 (hashq-ref *stmt-map* stmt)) 251 252 (define stmt-guardian (make-guardian)) 253 (define (pump-stmt-guardian) 254 (let ((stmt (stmt-guardian))) 255 (if stmt 256 (begin 257 (sqlite-finalize stmt) 258 (pump-stmt-guardian))))) 259 (add-hook! after-gc-hook pump-stmt-guardian) 260 261 (define sqlite-reset 262 (let ((reset (pointer->procedure 263 int 264 (dynamic-func "sqlite3_reset" libsqlite3) 265 (list '*)))) 266 (lambda (stmt) 267 (if (stmt-live? stmt) 268 (let ((p (stmt-pointer stmt))) 269 (set-stmt-reset?! stmt #t) 270 (reset p)) 271 (error "statement already finalized" stmt))))) 272 273 (define (assert-live-stmt! stmt) 274 (if (not (stmt-live? stmt)) 275 (error "statement already finalized" stmt))) 276 277 (define (assert-live-db! db) 278 (if (not (db-open? db)) 279 (error "database already closed" db))) 280 281 (define %sqlite-prepare 282 (let ((prepare (pointer->procedure 283 int 284 (dynamic-func "sqlite3_prepare_v2" libsqlite3) 285 (list '* '* int '* '*)))) 286 (lambda* (db sql #:key cache?) 287 (assert-live-db! db) 288 (let* ((out-stmt (bytevector->pointer (make-bytevector (sizeof '*) 0))) 289 (out-tail (bytevector->pointer (make-bytevector (sizeof '*) 0))) 290 (bv (string->utf8 sql)) 291 (bvp (bytevector->pointer bv)) 292 (ret (prepare (db-pointer db) 293 bvp 294 (bytevector-length bv) 295 out-stmt 296 out-tail))) 297 (if (zero? ret) 298 (if (= (bytevector-length bv) 299 (- (pointer-address (dereference-pointer out-tail)) 300 (pointer-address bvp))) 301 (let ((stmt (make-stmt (dereference-pointer out-stmt) #t #t 302 cache?))) 303 (stmt-guardian stmt) 304 (hashq-set! *stmt-map* stmt db) 305 stmt) 306 (error "input sql has useless tail" 307 (utf8-pointer->string 308 (dereference-pointer out-tail)))) 309 (check-error db 'sqlite-prepare)))))) 310 311 (define* (sqlite-prepare db sql #:key cache?) 312 (if cache? 313 (match (hash-ref (db-stmts db) sql) 314 (#f 315 (let ((stmt (%sqlite-prepare db sql #:cache? #t))) 316 (hash-set! (db-stmts db) sql stmt) 317 stmt)) 318 (stmt 319 (sqlite-reset stmt) 320 stmt)) 321 (%sqlite-prepare db sql))) 322 323 (define sqlite-bind-parameter-index 324 (let ((bind-parameter-index (pointer->procedure 325 int 326 (dynamic-func "sqlite3_bind_parameter_index" libsqlite3) 327 (list '* '*)))) 328 (lambda (stmt name) 329 (assert-live-stmt! stmt) 330 (let* ((ret (bind-parameter-index (stmt-pointer stmt) 331 (string->utf8-pointer name)))) 332 (if (> ret 0) 333 ret 334 (begin 335 (check-error (stmt->db stmt) 'sqlite-bind-parameter-index) 336 (write ret) 337 (newline) 338 (error "No such parameter" name))))))) 339 340 (define key->index 341 (lambda (stmt key) 342 (cond 343 ((string? key) (sqlite-bind-parameter-index stmt key)) 344 ((symbol? key) (sqlite-bind-parameter-index stmt 345 (string-append ":" (symbol->string key)))) 346 (else key)))) 347 348 (define sqlite-bind 349 (let ((bind-blob (pointer->procedure 350 int 351 (dynamic-func "sqlite3_bind_blob" libsqlite3) 352 (list '* int '* int '*))) 353 (bind-text (pointer->procedure 354 int 355 (dynamic-func "sqlite3_bind_text" libsqlite3) 356 (list '* int '* int '*))) 357 (bind-int64 (pointer->procedure 358 int 359 (dynamic-func "sqlite3_bind_int64" libsqlite3) 360 (list '* int int64))) 361 (bind-double (pointer->procedure 362 int 363 (dynamic-func "sqlite3_bind_double" libsqlite3) 364 (list '* int double))) 365 (bind-null (pointer->procedure 366 int 367 (dynamic-func "sqlite3_bind_null" libsqlite3) 368 (list '* int))) 369 (sqlite-transient (make-pointer 370 (bit-extract (lognot 0) 0 (* 8 (sizeof '*)))))) 371 (lambda (stmt key val) 372 (assert-live-stmt! stmt) 373 (let ((idx (key->index stmt key)) 374 (p (stmt-pointer stmt))) 375 (cond 376 ((bytevector? val) 377 (bind-blob p idx (bytevector->pointer val) (bytevector-length val) 378 sqlite-transient)) 379 ((string? val) 380 (let ((bv (string->utf8 val))) 381 (bind-text p idx (bytevector->pointer bv) (bytevector-length bv) 382 sqlite-transient))) 383 ((and (integer? val) (exact? val)) 384 (bind-int64 p idx val)) 385 ((number? val) 386 (bind-double p idx (exact->inexact val))) 387 ((not val) 388 (bind-null p idx)) 389 (else 390 (error "unexpected value" val))) 391 (check-error (stmt->db stmt)))))) 392 393 (define (sqlite-bind-arguments stmt . args) 394 (let loop ((i 1) 395 (args args)) 396 (match args 397 (() 398 #f) 399 (((? keyword? kw) value . rest) 400 (sqlite-bind stmt (keyword->symbol kw) value) 401 (loop i rest)) 402 ((arg . rest) 403 (sqlite-bind stmt i arg) 404 (loop (+ 1 i) rest))))) 405 406 (define sqlite-column-count 407 (let ((column-count 408 (pointer->procedure 409 int 410 (dynamic-pointer "sqlite3_column_count" libsqlite3) 411 (list '*)))) 412 (lambda (stmt) 413 (assert-live-stmt! stmt) 414 (column-count (stmt-pointer stmt))))) 415 416 (define sqlite-column-name 417 (let ((column-name 418 (pointer->procedure 419 '* 420 (dynamic-pointer "sqlite3_column_name" libsqlite3) 421 (list '* int)))) 422 (lambda (stmt i) 423 (assert-live-stmt! stmt) 424 (utf8-pointer->string (column-name (stmt-pointer stmt) i))))) 425 426 (define sqlite-column-value 427 (let ((value-type 428 (pointer->procedure 429 int 430 (dynamic-pointer "sqlite3_column_type" libsqlite3) 431 (list '* int))) 432 (value-int 433 (pointer->procedure 434 int64 435 (dynamic-pointer "sqlite3_column_int64" libsqlite3) 436 (list '* int))) 437 (value-double 438 (pointer->procedure 439 double 440 (dynamic-pointer "sqlite3_column_double" libsqlite3) 441 (list '* int))) 442 (value-text 443 (pointer->procedure 444 '* 445 (dynamic-pointer "sqlite3_column_text" libsqlite3) 446 (list '* int))) 447 (value-blob 448 (pointer->procedure 449 '* 450 (dynamic-pointer "sqlite3_column_blob" libsqlite3) 451 (list '* int))) 452 (value-bytes 453 (pointer->procedure 454 int 455 (dynamic-pointer "sqlite3_column_bytes" libsqlite3) 456 (list '* int)))) 457 (lambda (stmt i) 458 (assert-live-stmt! stmt) 459 (let ((nbytes (value-bytes (stmt-pointer stmt) i))) 460 (case (value-type (stmt-pointer stmt) i) 461 ((1) (value-int (stmt-pointer stmt) i)) 462 ((2) (value-double (stmt-pointer stmt) i)) 463 ((3) (let ((p (value-blob (stmt-pointer stmt) i))) 464 (if (null-pointer? p) 465 "" 466 (utf8->string (pointer->bytevector p nbytes))))) 467 ((4) (let ((p (value-blob (stmt-pointer stmt) i))) 468 (if (null-pointer? p) 469 (make-bytevector 0) 470 (bytevector-copy (pointer->bytevector p nbytes))))) 471 ((5) #f)))))) 472 473 (define (sqlite-column-names stmt) 474 (let ((v (make-vector (sqlite-column-count stmt)))) 475 (let lp ((i 0)) 476 (if (< i (vector-length v)) 477 (begin 478 (vector-set! v i (sqlite-column-name stmt i)) 479 (lp (1+ i))) 480 v)))) 481 482 (define (sqlite-row stmt) 483 (let ((v (make-vector (sqlite-column-count stmt)))) 484 (let lp ((i 0)) 485 (if (< i (vector-length v)) 486 (begin 487 (vector-set! v i (sqlite-column-value stmt i)) 488 (lp (1+ i))) 489 v)))) 490 491 (define sqlite-busy-timeout 492 (let ((f (pointer->procedure 493 int 494 (dynamic-func "sqlite3_busy_timeout" libsqlite3) 495 (list '* int)))) 496 (lambda (db value) 497 (assert-live-db! db) 498 (let ((ret (f (db-pointer db) value))) 499 (when (not (zero? ret)) 500 (check-error db 'sqlite-busy-timeout)))))) 501 502 (define trace-callback 503 (lambda (callback) 504 (procedure->pointer 505 int 506 (lambda (trace context p x) 507 (callback trace p x) 508 0) 509 (list unsigned-int '* '* '*)))) 510 511 (define sqlite-expanded-sql 512 (let ((proc (pointer->procedure 513 '* 514 (dynamic-func "sqlite3_expanded_sql" libsqlite3) 515 (list '*)))) 516 (lambda (stmt-pointer) 517 (proc stmt-pointer)))) 518 519 (define sqlite-trace 520 (let ((proc (pointer->procedure 521 int 522 (dynamic-func "sqlite3_trace_v2" libsqlite3) 523 (list '* unsigned-int '* '*)))) 524 (lambda (db mask callback) 525 (proc (db-pointer db) 526 mask 527 (trace-callback callback) 528 %null-pointer)))) 529 530 (define sqlite-step 531 (let ((step (pointer->procedure 532 int 533 (dynamic-pointer "sqlite3_step" libsqlite3) 534 (list '*)))) 535 (lambda (stmt) 536 (assert-live-stmt! stmt) 537 (let ((ret (step (stmt-pointer stmt)))) 538 (case ret 539 ((100) ; SQLITE_ROW 540 (sqlite-row stmt)) 541 ((101) ; SQLITE_DONE 542 #f) 543 (else 544 (check-error (stmt->db stmt)) 545 (error "shouldn't get here"))))))) 546 547 (define (sqlite-fold kons knil stmt) 548 (assert-live-stmt! stmt) 549 (let lp ((seed knil)) 550 (let ((row (sqlite-step stmt))) 551 (if row 552 (lp (kons row seed)) 553 seed)))) 554 555 (define (sqlite-fold-right kons knil stmt) 556 (assert-live-stmt! stmt) 557 (let lp () 558 (let ((row (sqlite-step stmt))) 559 (if row 560 (kons row (lp)) 561 knil)))) 562 563 (define (sqlite-map proc stmt) 564 (map proc 565 (reverse! (sqlite-fold cons '() stmt))))