Changeset 36618 in project
- Timestamp:
- 09/15/18 14:36:14 (2 years ago)
- Location:
- release/5/sqlite3/trunk
- Files:
-
- 1 added
- 2 deleted
- 2 edited
-
.bzrignore (deleted)
-
sqlite3.egg (added)
-
sqlite3.scm (modified) (20 diffs)
-
sqlite3.setup (deleted)
-
tests/run.scm (modified) (2 diffs)
Legend:
- Unmodified
- Added
- Removed
-
release/5/sqlite3/trunk/sqlite3.scm
r33349 r36618 1 ;;;; sqlite3.scm 2 ;;;; :tabSize=2:indentSize=2:noTabs=true: 3 ;;;; bindings to the SQLite3 database library 1 ;; This file is part of SQLite3 for CHICKEN 2 ;; Copyright (c) 2005-2018, Thomas Chust <chust@web.de>. All rights reserved. 3 ;; 4 ;; Redistribution and use in source and binary forms, with or without 5 ;; modification, are permitted provided that the following conditions are met: 6 ;; 7 ;; Redistributions of source code must retain the above copyright notice, 8 ;; this list of conditions and the following disclaimer. Redistributions in 9 ;; binary form must reproduce the above copyright notice, this list of 10 ;; conditions and the following disclaimer in the documentation and/or 11 ;; other materials provided with the distribution. Neither the name of the 12 ;; author nor the names of its contributors may be used to endorse or 13 ;; promote products derived from this software without specific prior 14 ;; written permission. 15 ;; 16 ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS 17 ;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 18 ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 19 ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR 20 ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 21 ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 22 ;; 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. 4 27 5 28 (declare … … 73 96 ) 74 97 75 (import scheme chicken foreign) 76 77 (use 78 srfi-1 srfi-13 srfi-18 srfi-69 79 data-structures extras lolevel 80 type-errors type-checks synch miscmacros matchable sql-null) 98 (import 99 scheme 100 (chicken base) 101 (chicken foreign) 102 (chicken condition) 103 (chicken string) 104 (chicken keyword) 105 (chicken fixnum) 106 (chicken blob) 107 (chicken memory) 108 (chicken format) 109 (srfi 1) 110 (srfi 13) 111 (srfi 18) 112 (srfi 69) 113 object-evict 114 type-errors 115 type-checks 116 synch 117 miscmacros 118 matchable 119 sql-null) 81 120 82 121 ;;; Foreign types & values … … 103 142 104 143 (%define-enum-type (sqlite3:status "sqlite3_status") 105 (#f "SQLITE_OK"); Successful result106 (error "SQLITE_ERROR"); SQL error or missing database107 (internal "SQLITE_INTERNAL"); NOT USED. Internal logic error in SQLite108 (permission "SQLITE_PERM"); Access permission denied109 (abort "SQLITE_ABORT"); Callback routine requested an abort110 (busy "SQLITE_BUSY"); The database file is locked111 (locked "SQLITE_LOCKED"); A table in the database is locked112 (no-memory "SQLITE_NOMEM"); A malloc() failed113 (read-only "SQLITE_READONLY"); Attempt to write a readonly database114 (interrupt "SQLITE_INTERRUPT"); Operation terminated by sqlite3_interrupt()115 (io-error "SQLITE_IOERR"); Some kind of disk I/O error occurred116 (corrupt "SQLITE_CORRUPT"); The database disk image is malformed117 (not-found "SQLITE_NOTFOUND"); NOT USED. Table or record not found118 (full "SQLITE_FULL"); Insertion failed because database is full119 (cant-open "SQLITE_CANTOPEN"); Unable to open the database file120 (protocol "SQLITE_PROTOCOL"); NOT USED. Database lock protocol error121 (empty "SQLITE_EMPTY"); Database is empty122 (schema "SQLITE_SCHEMA"); The database schema changed123 (too-big "SQLITE_TOOBIG"); String or BLOB exceeds size limit124 (constraint "SQLITE_CONSTRAINT"); Abort due to contraint violation125 (mismatch "SQLITE_MISMATCH"); Data type mismatch126 (misuse "SQLITE_MISUSE"); Library used incorrectly127 (no-lfs "SQLITE_NOLFS"); Uses OS features not supported on host128 (authorization "SQLITE_AUTH"); Authorization denied129 (format "SQLITE_FORMAT"); Auxiliary database format error130 (range "SQLITE_RANGE"); 2nd parameter to sqlite3_bind out of range131 (not-a-database "SQLITE_NOTADB"); File opened that is not a database file132 (row "SQLITE_ROW"); sqlite3_step() has another row ready133 (done "SQLITE_DONE")); sqlite3_step() has finished executing144 (#f "SQLITE_OK") ; Successful result 145 (error "SQLITE_ERROR") ; SQL error or missing database 146 (internal "SQLITE_INTERNAL") ; NOT USED. Internal logic error in SQLite 147 (permission "SQLITE_PERM") ; Access permission denied 148 (abort "SQLITE_ABORT") ; Callback routine requested an abort 149 (busy "SQLITE_BUSY") ; The database file is locked 150 (locked "SQLITE_LOCKED") ; A table in the database is locked 151 (no-memory "SQLITE_NOMEM") ; A malloc() failed 152 (read-only "SQLITE_READONLY") ; Attempt to write a readonly database 153 (interrupt "SQLITE_INTERRUPT") ; Operation terminated by sqlite3_interrupt() 154 (io-error "SQLITE_IOERR") ; Some kind of disk I/O error occurred 155 (corrupt "SQLITE_CORRUPT") ; The database disk image is malformed 156 (not-found "SQLITE_NOTFOUND") ; NOT USED. Table or record not found 157 (full "SQLITE_FULL") ; Insertion failed because database is full 158 (cant-open "SQLITE_CANTOPEN") ; Unable to open the database file 159 (protocol "SQLITE_PROTOCOL") ; NOT USED. Database lock protocol error 160 (empty "SQLITE_EMPTY") ; Database is empty 161 (schema "SQLITE_SCHEMA") ; The database schema changed 162 (too-big "SQLITE_TOOBIG") ; String or BLOB exceeds size limit 163 (constraint "SQLITE_CONSTRAINT") ; Abort due to contraint violation 164 (mismatch "SQLITE_MISMATCH") ; Data type mismatch 165 (misuse "SQLITE_MISUSE") ; Library used incorrectly 166 (no-lfs "SQLITE_NOLFS") ; Uses OS features not supported on host 167 (authorization "SQLITE_AUTH") ; Authorization denied 168 (format "SQLITE_FORMAT") ; Auxiliary database format error 169 (range "SQLITE_RANGE") ; 2nd parameter to sqlite3_bind out of range 170 (not-a-database "SQLITE_NOTADB") ; File opened that is not a database file 171 (row "SQLITE_ROW") ; sqlite3_step() has another row ready 172 (done "SQLITE_DONE")) ; sqlite3_step() has finished executing 134 173 135 174 (%define-enum-type (sqlite3:type "sqlite3_type") 136 (integer 137 (float 138 (text 139 (blob 140 (null 175 (integer "SQLITE_INTEGER") 176 (float "SQLITE_FLOAT") 177 (text "SQLITE_TEXT") 178 (blob "SQLITE_BLOB") 179 (null "SQLITE_NULL")) 141 180 142 181 ;; Auxiliary types … … 225 264 ;; Tree dictionary 226 265 227 (define (make- hash-table-tree/synchid . args)228 (make- object/synch(apply make-hash-table args) id))266 (define (make-synch-hash-table-tree id . args) 267 (make-synch-with-object (apply make-hash-table args) id)) 229 268 230 269 (define (hash-table-tree-set! ht-tree keys value) … … 272 311 ;; SQL collation sequence interface 273 312 274 (define *collations* (make- hash-table-tree/synch'sqlite3:collations))313 (define *collations* (make-synch-hash-table-tree 'sqlite3:collations)) 275 314 276 315 (define-external (chicken_sqlite3_collation_stub … … 291 330 (set! r 292 331 ((vector-ref 293 (call- with/synch *collations*332 (call-synch-with *collations* 294 333 (cute hash-table-tree-ref <> qn)) 295 334 1) … … 331 370 ((abort-sqlite3-error 'define-collation db name proc) s))] 332 371 [else 333 (call- with/synch *collations*372 (call-synch-with *collations* 334 373 (cute hash-table-tree-set! <> qn (vector qn proc)))]))) 335 374 (cond … … 338 377 [else 339 378 (let ([qn (list (pointer->address (database-ptr db)) name)]) 340 (call- with/synch *collations*379 (call-synch-with *collations* 341 380 (lambda (col) 342 381 (cond [(hash-table-tree-ref/default col qn #f) … … 347 386 ;;; SQL function interface 348 387 349 (define *functions* (make- hash-table-tree/synch'sqlite3:functions))350 351 (define *seeds* (make- hash-table-tree/synch'sqlite3:seeds))388 (define *functions* (make-synch-hash-table-tree 'sqlite3:functions)) 389 390 (define *seeds* (make-synch-hash-table-tree 'sqlite3:seeds)) 352 391 353 392 (define (parameter-data n args) … … 426 465 ctx 427 466 (apply (vector-ref 428 (call- with/synch *functions*467 (call-synch-with *functions* 429 468 (cute hash-table-tree-ref <> (sqlite3_user_data ctx))) 430 469 1) … … 445 484 (handle-exceptions exn 446 485 (print-error "in step of SQL function" exn) 447 (let ([info (call- with/synch *functions*486 (let ([info (call-synch-with *functions* 448 487 (cute hash-table-tree-ref <> (sqlite3_user_data ctx)))]) 449 (call- with/synch *seeds*488 (call-synch-with *seeds* 450 489 (cute hash-table-update!/default 451 490 <> … … 466 505 (handle-exceptions exn 467 506 (print-error "in final of SQL function" exn) 468 (let ([info (call- with/synch *functions*507 (let ([info (call-synch-with *functions* 469 508 (cute hash-table-tree-ref <> (sqlite3_user_data ctx)))]) 470 509 (cond 471 510 [((vector-ref info 3) 472 (call- with/synch *seeds*511 (call-synch-with *seeds* 473 512 (cute hash-table-ref/default <> agc (vector-ref info 2)))) 474 513 => (cute set-result! ctx <>)] … … 476 515 (set-result! ctx (sql-null))])))) 477 516 (lambda () 478 (call- with/synch *seeds*517 (call-synch-with *seeds* 479 518 (cute hash-table-delete! <> agc)) 480 519 (return (void))))))) … … 485 524 (check-database 'define-function db) 486 525 (check-string 'define-function name) 487 (check- cardinal-number 'define-function (fx+ n 1))526 (check-natural-number 'define-function (fx+ n 1)) 488 527 (check-procedure 'define-function proc) 489 528 (let ([qn (object-evict (list (pointer->address (database-ptr db)) name))]) … … 507 546 ((abort-sqlite3-error 'define-function db name n proc) s))] 508 547 [else 509 (call- with/synch *functions*548 (call-synch-with *functions* 510 549 (cute hash-table-tree-set! <> qn (vector qn proc)))]))] 511 550 [(db name n step-proc seed . final-proc) 512 551 (check-database 'define-function db) 513 552 (check-string 'define-function name) 514 (check- cardinal-number 'define-function (fx+ n 1))553 (check-natural-number 'define-function (fx+ n 1)) 515 554 (let ([final-proc (optional final-proc identity)]) 516 555 (check-procedure 'define-function step-proc) … … 538 577 'define-function db name n step-proc seed final-proc) s))] 539 578 [else 540 (call- with/synch *functions*579 (call-synch-with *functions* 541 580 (cute hash-table-tree-set! <> qn (vector qn step-proc seed final-proc)))])))])) 542 581 … … 572 611 (thread-sleep! (/ ms 1000))) 573 612 (let* ([delays '#(1 2 5 10 15 20 25 25 25 50 50 100)] 574 575 613 [totals '#(0 1 3 8 18 33 53 78 103 128 178 228)] 614 [ndelay (vector-length delays)]) 576 615 (lambda (db count) 577 616 (let* ([delay (vector-ref delays (fxmin count (fx- ndelay 1)))] 578 579 580 581 582 583 584 585 586 587 588 589 617 [prior (if (fx< count ndelay) 618 (vector-ref totals count) 619 (fx+ (vector-ref totals (fx- ndelay 1)) 620 (fx* delay (fx- count (fx- ndelay 1)))))]) 621 (let ([delay (if (fx> (fx+ prior delay) timeout) 622 (fx- timeout prior) 623 delay)]) 624 (cond 625 [(fx<= delay 0) #f] 626 [else 627 (thread-sleep!/ms delay) 628 #t])))))) 590 629 591 630 ;; Cancel any running database operation as soon as possible … … 635 674 (let ([id (pointer->address (database-ptr db))] 636 675 [release-qns (lambda (_ info) (object-release (vector-ref info 0)))]) 637 (call- with/synch *collations*676 (call-synch-with *collations* 638 677 (cute hash-table-tree-clear! <> id release-qns)) 639 (call- with/synch *functions*678 (call-synch-with *functions* 640 679 (cute hash-table-tree-clear! <> id release-qns)) 641 680 (database-ptr-set! db #f) … … 717 756 (define (bind! stmt i v) 718 757 (check-statement 'bind! stmt) 719 (check- cardinal-integer 'bind! i)758 (check-natural-integer 'bind! i) 720 759 (cond 721 760 [(blob? v) … … 1049 1088 1050 1089 ) 1090 1091 ;; vim: set ai et ts=8 sts=2 sw=2 ft=scheme: ;; -
release/5/sqlite3/trunk/tests/run.scm
r29988 r36618 1 ;;;; test.scm 2 ;;;; :tabSize=2:indentSize=2:noTabs=true: 3 ;;;; Tests for the SQLite3 bindings 4 5 (use srfi-1 srfi-13 srfi-69 test sql-null sqlite3) 1 ;; This file is part of SQLite3 for CHICKEN 2 ;; Copyright (c) 2005-2018, Thomas Chust <chust@web.de>. All rights reserved. 3 ;; 4 ;; Redistribution and use in source and binary forms, with or without 5 ;; modification, are permitted provided that the following conditions are met: 6 ;; 7 ;; Redistributions of source code must retain the above copyright notice, 8 ;; this list of conditions and the following disclaimer. Redistributions in 9 ;; binary form must reproduce the above copyright notice, this list of 10 ;; conditions and the following disclaimer in the documentation and/or 11 ;; other materials provided with the distribution. Neither the name of the 12 ;; author nor the names of its contributors may be used to endorse or 13 ;; promote products derived from this software without specific prior 14 ;; written permission. 15 ;; 16 ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS 17 ;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 18 ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 19 ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR 20 ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 21 ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 22 ;; 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 (import 29 scheme 30 (chicken blob) 31 (srfi 1) 32 (srfi 13) 33 (srfi 69) 34 test 35 sql-null 36 sqlite3) 6 37 7 38 ;;; Some utilities … … 310 341 311 342 (test-exit) 343 344 ;; vim: set ai et ts=8 sts=2 sw=2 ft=scheme: ;;
Note: See TracChangeset
for help on using the changeset viewer.
