Changeset 36618 in project


Ignore:
Timestamp:
09/15/18 14:36:14 (2 months ago)
Author:
chust
Message:

[sqlite3] Ported CHICKEN 4 code to CHICKEN 5, thanks to Vasilij for patches

Location:
release/5/sqlite3/trunk
Files:
1 added
2 deleted
2 edited

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.
    427
    528(declare
     
    7396  )
    7497
    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)
    81120
    82121;;; Foreign types & values
     
    103142
    104143(%define-enum-type (sqlite3:status "sqlite3_status")
    105   (#f                                                           "SQLITE_OK")      ; Successful result
    106   (error                                "SQLITE_ERROR")   ; SQL error or missing database
    107   (internal                                     "SQLITE_INTERNAL")        ; NOT USED. Internal logic error in SQLite
    108   (permission                           "SQLITE_PERM")    ; Access permission denied
    109   (abort                                "SQLITE_ABORT")   ; Callback routine requested an abort
    110   (busy                                 "SQLITE_BUSY")    ; The database file is locked
    111   (locked                               "SQLITE_LOCKED")          ; A table in the database is locked
    112   (no-memory                    "SQLITE_NOMEM")   ; A malloc() failed
    113   (read-only                    "SQLITE_READONLY")        ; Attempt to write a readonly database
    114   (interrupt                    "SQLITE_INTERRUPT")       ; Operation terminated by sqlite3_interrupt()
    115   (io-error                     "SQLITE_IOERR")   ; Some kind of disk I/O error occurred
    116   (corrupt                      "SQLITE_CORRUPT")         ; The database disk image is malformed
    117   (not-found                    "SQLITE_NOTFOUND")        ; NOT USED. Table or record not found
    118   (full                                 "SQLITE_FULL")    ; Insertion failed because database is full
    119   (cant-open                    "SQLITE_CANTOPEN")        ; Unable to open the database file
    120   (protocol                     "SQLITE_PROTOCOL")        ; NOT USED. Database lock protocol error
    121   (empty                                "SQLITE_EMPTY")   ; Database is empty
    122   (schema                               "SQLITE_SCHEMA")          ; The database schema changed
    123   (too-big                      "SQLITE_TOOBIG")          ; String or BLOB exceeds size limit
    124   (constraint                   "SQLITE_CONSTRAINT")      ; Abort due to contraint violation
    125   (mismatch                     "SQLITE_MISMATCH")        ; Data type mismatch
    126   (misuse                               "SQLITE_MISUSE")          ; Library used incorrectly
    127   (no-lfs                               "SQLITE_NOLFS")   ; Uses OS features not supported on host
    128   (authorization                "SQLITE_AUTH")    ; Authorization denied
    129   (format                               "SQLITE_FORMAT")          ; Auxiliary database format error
    130   (range                                "SQLITE_RANGE")   ; 2nd parameter to sqlite3_bind out of range
    131   (not-a-database               "SQLITE_NOTADB")          ; File opened that is not a database file
    132   (row                                  "SQLITE_ROW")             ; sqlite3_step() has another row ready
    133   (done                                 "SQLITE_DONE"))   ; sqlite3_step() has finished executing
     144  (#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
    134173
    135174(%define-enum-type (sqlite3:type "sqlite3_type")
    136   (integer      "SQLITE_INTEGER")
    137   (float                "SQLITE_FLOAT")
    138   (text                 "SQLITE_TEXT")
    139   (blob                 "SQLITE_BLOB")
    140   (null                 "SQLITE_NULL"))
     175  (integer      "SQLITE_INTEGER")
     176  (float                "SQLITE_FLOAT")
     177  (text                 "SQLITE_TEXT")
     178  (blob                 "SQLITE_BLOB")
     179  (null                 "SQLITE_NULL"))
    141180
    142181;; Auxiliary types
     
    225264;; Tree dictionary
    226265
    227 (define (make-hash-table-tree/synch id . 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))
    229268
    230269(define (hash-table-tree-set! ht-tree keys value)
     
    272311;; SQL collation sequence interface
    273312
    274 (define *collations* (make-hash-table-tree/synch 'sqlite3:collations))
     313(define *collations* (make-synch-hash-table-tree 'sqlite3:collations))
    275314
    276315(define-external (chicken_sqlite3_collation_stub
     
    291330              (set! r
    292331                ((vector-ref
    293                   (call-with/synch *collations*
     332                  (call-synch-with *collations*
    294333                    (cute hash-table-tree-ref <> qn))
    295334                  1)
     
    331370    ((abort-sqlite3-error 'define-collation db name proc) s))]
    332371    [else
    333       (call-with/synch *collations*
     372      (call-synch-with *collations*
    334373        (cute hash-table-tree-set! <> qn (vector qn proc)))])))
    335374    (cond
     
    338377      [else
    339378        (let ([qn (list (pointer->address (database-ptr db)) name)])
    340           (call-with/synch *collations*
     379          (call-synch-with *collations*
    341380            (lambda (col)
    342381              (cond [(hash-table-tree-ref/default col qn #f)
     
    347386;;; SQL function interface
    348387
    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))
    352391
    353392(define (parameter-data n args)
     
    426465            ctx
    427466            (apply (vector-ref
    428                       (call-with/synch *functions*
     467                      (call-synch-with *functions*
    429468                        (cute hash-table-tree-ref <> (sqlite3_user_data ctx)))
    430469                      1)
     
    445484        (handle-exceptions exn
    446485          (print-error "in step of SQL function" exn)
    447           (let ([info (call-with/synch *functions*
     486          (let ([info (call-synch-with *functions*
    448487                        (cute hash-table-tree-ref <> (sqlite3_user_data ctx)))])
    449             (call-with/synch *seeds*
     488            (call-synch-with *seeds*
    450489              (cute hash-table-update!/default
    451490                <>
     
    466505          (handle-exceptions exn
    467506            (print-error "in final of SQL function" exn)
    468             (let ([info (call-with/synch *functions*
     507            (let ([info (call-synch-with *functions*
    469508            (cute hash-table-tree-ref <> (sqlite3_user_data ctx)))])
    470509              (cond
    471510          [((vector-ref info 3)
    472             (call-with/synch *seeds*
     511            (call-synch-with *seeds*
    473512              (cute hash-table-ref/default <> agc (vector-ref info 2))))
    474513            => (cute set-result! ctx <>)]
     
    476515            (set-result! ctx (sql-null))]))))
    477516        (lambda ()
    478           (call-with/synch *seeds*
     517          (call-synch-with *seeds*
    479518            (cute hash-table-delete! <> agc))
    480519          (return (void)))))))
     
    485524      (check-database 'define-function db)
    486525      (check-string 'define-function name)
    487       (check-cardinal-number 'define-function (fx+ n 1))
     526      (check-natural-number 'define-function (fx+ n 1))
    488527      (check-procedure 'define-function proc)
    489528      (let ([qn (object-evict (list (pointer->address (database-ptr db)) name))])
     
    507546          ((abort-sqlite3-error 'define-function db name n proc) s))]
    508547    [else
    509       (call-with/synch *functions*
     548      (call-synch-with *functions*
    510549        (cute hash-table-tree-set! <> qn (vector qn proc)))]))]
    511550    [(db name n step-proc seed . final-proc)
    512551      (check-database 'define-function db)
    513552      (check-string 'define-function name)
    514       (check-cardinal-number 'define-function (fx+ n 1))
     553      (check-natural-number 'define-function (fx+ n 1))
    515554      (let ([final-proc (optional final-proc identity)])
    516555        (check-procedure 'define-function step-proc)
     
    538577                      'define-function db name n step-proc seed final-proc) s))]
    539578            [else
    540               (call-with/synch *functions*
     579              (call-synch-with *functions*
    541580                (cute hash-table-tree-set! <> qn (vector qn step-proc seed final-proc)))])))]))
    542581
     
    572611    (thread-sleep! (/ ms 1000)))
    573612  (let* ([delays '#(1 2 5 10 15 20 25 25 25 50 50 100)]
    574         [totals '#(0 1 3  8 18 33 53 78 103 128 178 228)]
    575         [ndelay (vector-length delays)])
     613        [totals '#(0 1 3  8 18 33 53 78 103 128 178 228)]
     614        [ndelay (vector-length delays)])
    576615    (lambda (db count)
    577616      (let* ([delay (vector-ref delays (fxmin count (fx- ndelay 1)))]
    578              [prior (if (fx< count ndelay)
    579                         (vector-ref totals count)
    580                         (fx+ (vector-ref totals (fx- ndelay 1))
    581                              (fx* delay (fx- count (fx- ndelay 1)))))])
    582         (let ([delay (if (fx> (fx+ prior delay) timeout)
    583                         (fx- timeout prior)
    584                         delay)])
    585           (cond
    586            [(fx<= delay 0) #f]
    587            [else
    588             (thread-sleep!/ms delay)
    589             #t]))))))
     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]))))))
    590629
    591630;; Cancel any running database operation as soon as possible
     
    635674          (let ([id (pointer->address (database-ptr db))]
    636675                [release-qns (lambda (_ info) (object-release (vector-ref info 0)))])
    637             (call-with/synch *collations*
     676            (call-synch-with *collations*
    638677              (cute hash-table-tree-clear! <> id release-qns))
    639             (call-with/synch *functions*
     678            (call-synch-with *functions*
    640679              (cute hash-table-tree-clear! <> id release-qns))
    641680            (database-ptr-set! db #f)
     
    717756(define (bind! stmt i v)
    718757  (check-statement 'bind! stmt)
    719   (check-cardinal-integer 'bind! i)
     758  (check-natural-integer 'bind! i)
    720759  (cond
    721760    [(blob? v)
     
    10491088
    10501089)
     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)
    637
    738;;; Some utilities
     
    310341
    311342(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.