lmdb

Check-in [6ef9d5e1d4]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Conversions between databases and association lists
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA3-256: 6ef9d5e1d47dfd905a308eca9fec4da974faa9bec4a565823570ff1b9223ba73
User & Date: murphy 2018-08-20 21:13:29
Context
2018-08-20
21:13
Initial documentation check-in: 79aad68b11 user: murphy tags: trunk
21:13
Conversions between databases and association lists check-in: 6ef9d5e1d4 user: murphy tags: trunk
18:09
Set current-database-environment to #f when it is closed check-in: 9f4cd15298 user: murphy tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to lmdb.scm.

3
4
5
6
7
8
9
10

11
12
13
14
15
16
17
...
322
323
324
325
326
327
328











329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
...
370
371
372
373
374
375
376

















377
378
379
380
381
382
383
...
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
...
542
543
544
545
546
547
548
549

















550





















551


552
   current-database-environment
   open-database-environment close-database-environment
   copy-database-environment
   with-transaction
   database?
   open-database close-database drop-database
   database-ref database-set! database-exists? database-delete!
   database-fold database-walk)


(import
  scheme
  (chicken base)
  (chicken blob)
  (chicken fixnum)
  (chicken keyword)
................................................................................
  [#:reverse-key "MDB_REVERSEKEY"]
  [#:duplicate-sort "MDB_DUPSORT"]
  [#:integer-key "MDB_INTEGERKEY"]
  [#:duplicate-fixed "MDB_DUPFIXED"]
  [#:integer-duplicate "MDB_INTEGERDUP"]
  [#:reverse-duplicate "MDB_REVERSEDUP"]
  [#:create "MDB_CREATE"])












(define (open-database . args)
  (let-keys+flags open-database args
                  ([0 name #f])
                  ([database-flags flags])
    (let-location ([dbi database (wrap-database 0)])
      (check-error
       'open-database
       ((foreign-lambda
         int "mdb_dbi_open"
         nonnull-transaction c-string unsigned-int
         (nonnull-c-pointer database))
        (current-transaction) name flags (location dbi)))
      dbi)))

(define (close-database dbi #!optional [env (current-database-environment)])
  ((foreign-lambda
    void "mdb_dbi_close"
    nonnull-database-environment database)
   env dbi))

................................................................................
   [else 0]))

(define-foreign-enum-argconvert (database-set!-flags unsigned-int)
  [#:no-duplicate "MDB_NODUPDATA"]
  [#:no-overwrite "MDB_NOOVERWRITE"]
  [#:append "MDB_APPEND"]
  [#:append/duplicate "MDB_APPENDDUP"])


















(define-values (database-ref database-set!)
  (letrec ([database-ref
            (lambda (dbi key #!optional [default (cut check-error 'database-ref not-found)])
              (let-location ([vlen size_t 0] [vptr c-pointer #f])
                (let ([status
                       ((foreign-lambda*
................................................................................
                    [else
                     (check-error 'database-ref status)]))))]
           [database-set!
            (lambda (dbi key val . args)
              (let-keys+flags database-set! args
                              ()
                              ([database-set!-flags flags])
                (check-error
                 'database-set!
                 ((foreign-lambda*
                   int ([nonnull-transaction txn] [database dbi]
                        [size_t klen] [scheme-pointer kptr]
                        [size_t vlen] [scheme-pointer vptr]
                        [unsigned-int flags])
                   "MDB_val key, val;"
                   "key.mv_size = klen; key.mv_data = kptr;"
                   "val.mv_size = vlen; val.mv_data = vptr;"
                   "C_return(mdb_put(txn, dbi, &key, &val, flags));")
                  (current-transaction) dbi
                  (blob/string-size key) key
                  (blob/string-size val) val
                  flags))))])
    (values
     (getter-with-setter database-ref database-set!)
     database-set!)))

(define (database-exists? dbi key)
  (let ([status
         ((foreign-lambda*
................................................................................
          (set! complete? #t))))))

(define (database-walk proc dbi . args)
  (apply
   database-fold
   (lambda (key val seed) (proc key val) seed) (void)
   dbi args))


















)
























;; vim: set ai et ts=8 sts=2 sw=2 ft=scheme: ;;







|
>







 







>
>
>
>
>
>
>
>
>
>
>





<
<
|
<
<
<
<
<
<







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







<
|
<
<
<
<
<
<
<
<
<
<
<
<
<







 








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

>
>

3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
...
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345


346






347
348
349
350
351
352
353
...
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
...
425
426
427
428
429
430
431

432













433
434
435
436
437
438
439
...
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
   current-database-environment
   open-database-environment close-database-environment
   copy-database-environment
   with-transaction
   database?
   open-database close-database drop-database
   database-ref database-set! database-exists? database-delete!
   database-fold database-walk
   database->alist alist->database)

(import
  scheme
  (chicken base)
  (chicken blob)
  (chicken fixnum)
  (chicken keyword)
................................................................................
  [#:reverse-key "MDB_REVERSEKEY"]
  [#:duplicate-sort "MDB_DUPSORT"]
  [#:integer-key "MDB_INTEGERKEY"]
  [#:duplicate-fixed "MDB_DUPFIXED"]
  [#:integer-duplicate "MDB_INTEGERDUP"]
  [#:reverse-duplicate "MDB_REVERSEDUP"]
  [#:create "MDB_CREATE"])

(define (%open-database name flags)
  (let-location ([dbi database (wrap-database 0)])
    (check-error
     'open-database
     ((foreign-lambda
       int "mdb_dbi_open"
       nonnull-transaction c-string unsigned-int
       (nonnull-c-pointer database))
      (current-transaction) name flags (location dbi)))
    dbi))

(define (open-database . args)
  (let-keys+flags open-database args
                  ([0 name #f])
                  ([database-flags flags])


    (%open-database name flags)))







(define (close-database dbi #!optional [env (current-database-environment)])
  ((foreign-lambda
    void "mdb_dbi_close"
    nonnull-database-environment database)
   env dbi))

................................................................................
   [else 0]))

(define-foreign-enum-argconvert (database-set!-flags unsigned-int)
  [#:no-duplicate "MDB_NODUPDATA"]
  [#:no-overwrite "MDB_NOOVERWRITE"]
  [#:append "MDB_APPEND"]
  [#:append/duplicate "MDB_APPENDDUP"])

(define (%database-set! dbi key val flags)
  (check-error
   'database-set!
   ((foreign-lambda*
     int ([nonnull-transaction txn] [database dbi]
          [size_t klen] [scheme-pointer kptr]
          [size_t vlen] [scheme-pointer vptr]
          [unsigned-int flags])
     "MDB_val key, val;"
     "key.mv_size = klen; key.mv_data = kptr;"
     "val.mv_size = vlen; val.mv_data = vptr;"
     "C_return(mdb_put(txn, dbi, &key, &val, flags));")
    (current-transaction) dbi
    (blob/string-size key) key
    (blob/string-size val) val
    flags)))

(define-values (database-ref database-set!)
  (letrec ([database-ref
            (lambda (dbi key #!optional [default (cut check-error 'database-ref not-found)])
              (let-location ([vlen size_t 0] [vptr c-pointer #f])
                (let ([status
                       ((foreign-lambda*
................................................................................
                    [else
                     (check-error 'database-ref status)]))))]
           [database-set!
            (lambda (dbi key val . args)
              (let-keys+flags database-set! args
                              ()
                              ([database-set!-flags flags])

                (%database-set! dbi key val flags)))])













    (values
     (getter-with-setter database-ref database-set!)
     database-set!)))

(define (database-exists? dbi key)
  (let ([status
         ((foreign-lambda*
................................................................................
          (set! complete? #t))))))

(define (database-walk proc dbi . args)
  (apply
   database-fold
   (lambda (key val seed) (proc key val) seed) (void)
   dbi args))

(define (database->alist dbi #!rest args #!key from to< to<=)
  (reverse!
   (database-fold
    (if (memq #:duplicate-list args)
        (lambda (key val rest)
          (if (pair? rest)
              (if (equal? key (caar rest))
                  (begin
                    (set-cdr! (car rest) (cons val (cdar rest)))
                    rest)
                  (begin
                    (set-cdr! (car rest) (reverse! (cdar rest)))
                    (cons (cons key (list val)) rest)))
              (cons (cons key (list val)) rest)))
        (lambda (key val rest)
          (cons (cons key val) rest)))
    '() dbi #:from from #:to< to< #:to<= to<=)))

(define (alist->database alist . args)
  (let-keys+flags open-database args
                  ([0 name #f])
                  ([database-flags dbi-flags]
                   [database-set!-flags set-flags])
    (let ([dbi (%open-database name dbi-flags)])
      (handle-exceptions exn
        (begin
          (close-database dbi)
          (abort exn))
        (for-each
          (lambda (key+val)
            (let ([key (car key+val)]
                  [val (cdr key+val)])
              (if (list? val)
                  (for-each
                    (cut %database-set! dbi key <> set-flags)
                    val)
                  (%database-set! dbi key val set-flags))))
          alist))
      dbi)))

)

;; vim: set ai et ts=8 sts=2 sw=2 ft=scheme: ;;