summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorpukkamustard <pukkamustard@posteo.net>2021-01-09 09:27:30 +0100
committerpukkamustard <pukkamustard@posteo.net>2021-01-09 09:27:30 +0100
commitd7df5a81bf1c8124e9bd31f887c102dd20b94999 (patch)
tree95dcfd5ae92cd3a188a3e9b5e64638f52661569a
parent1d7ec31b14a60b73339341bc34ee356d7e5d638d (diff)
(lmdb): Add lmdb-range
-rw-r--r--Makefile.am3
-rw-r--r--guix.scm11
-rw-r--r--hall.scm3
-rw-r--r--lmdb.scm64
-rw-r--r--lmdb/low-level.scm57
-rw-r--r--tests/lmdb.scm77
-rw-r--r--tests/lmdb/low-level.scm33
7 files changed, 218 insertions, 30 deletions
diff --git a/Makefile.am b/Makefile.am
index 0947327..c6901d5 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -38,7 +38,8 @@ SOURCES = lmdb.scm \
lmdb/internal.scm \
lmdb/low-level.scm
-TESTS = tests/lmdb/low-level.scm
+TESTS = tests/lmdb.scm \
+ tests/lmdb/low-level.scm
TEST_EXTENSIONS = .scm
SCM_LOG_DRIVER = \
diff --git a/guix.scm b/guix.scm
index 98622b3..eeefd1c 100644
--- a/guix.scm
+++ b/guix.scm
@@ -22,11 +22,12 @@
("automake" ,automake)
("pkg-config" ,pkg-config)
("texinfo" ,texinfo)))
- (inputs `(("guile" ,guile-3.0)
- ("lmdb" ,lmdb)))
- (propagated-inputs `())
+ (inputs
+ `(("guile" ,guile-3.0)
+ ("lmdb" ,lmdb)))
+ (propagated-inputs
+ `(("guile-srfi-158" ,guile-srfi-158)))
(synopsis "")
(description "")
- (home-page
- "https://inqlab.net/git/guile-lmdb.git")
+ (home-page "https://inqlab.net/git/guile-lmdb.git")
(license license:gpl3+))
diff --git a/hall.scm b/hall.scm
index fcc7ccf..71c7b72 100644
--- a/hall.scm
+++ b/hall.scm
@@ -15,7 +15,8 @@
(scheme-file "low-level")))))
(tests
((directory "tests"
- ((directory "lmdb" ((scheme-file "low-level")))))))
+ ((scheme-file "lmdb")
+ (directory "lmdb" ((scheme-file "low-level")))))))
(programs ((directory "scripts" ())))
(documentation
((org-file "README")
diff --git a/lmdb.scm b/lmdb.scm
index ebb3981..8495c8a 100644
--- a/lmdb.scm
+++ b/lmdb.scm
@@ -6,6 +6,7 @@
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
+ #:use-module (srfi srfi-158)
#:use-module (rnrs io ports)
@@ -19,7 +20,12 @@
<lmdb-db>
lmdb-db?
- lmdb-open))
+ lmdb-open
+ lmdb-close
+ lmdb-get
+ lmdb-put!
+ lmdb-delete!
+ lmdb-range))
;; Error handling
@@ -45,17 +51,30 @@
(define* (lmdb-open path #:key db-name)
- ;; create and open environment
+ ;; create environment
(define env (mdb-env-create))
- (mdb-env-open env path)
+ (unless (mdb-env? env)
+ (raise-lmdb-error env))
- ;; create a transaction and open a database
+ ;; open environment
+ (define mdb-env-open-return-code (mdb-env-open env path))
+ (unless (eqv? MDB_SUCCESS mdb-env-open-return-code)
+ (raise-lmdb-error mdb-env-open-return-code))
+
+ ;; create a transaction
(define txn (mdb-txn-begin env))
+ (unless (mdb-txn? txn)
+ (raise-lmdb-error txn))
+
+ ;; open a database
+ ;; TODO error handling
(define dbi (mdb-dbi-open txn))
;; commit transaction so that database handle can now be used from other
;; transactions
- (mdb-txn-commit txn)
+ (define mdb-txn-commit-return-code (mdb-txn-commit txn))
+ (unless (eqv? MDB_SUCCESS mdb-txn-commit-return-code)
+ (raise-lmdb-error mdb-txn-commit-return-code))
(&make-lmdb-db env dbi #f))
@@ -103,5 +122,36 @@
((eqv? return-value MDB_NOTFOUND) #f)
(else (raise-lmdb-error return-value)))))
-
-;; (lmdb-delete! db (string->utf8 "hi"))
+(define (lmdb-range db start-key end-key)
+ (let* ((txn (mdb-txn-begin (lmdb-db-env db)))
+ (cursor (mdb-cursor-open txn (lmdb-db-dbi db)))
+ ;; wrap start-key and end-key as mdb-val
+ (start-key-val (make-mdb-val start-key))
+ (end-key-val (make-mdb-val end-key))
+ ;; get an initial value with mdb-cursor-set
+ (init-value (mdb-cursor-set cursor start-key-val MDB_SET_RANGE)))
+ (make-coroutine-generator
+ (lambda (yield)
+ (let next ((return-value init-value))
+ (cond
+
+ ;; returned value is a key-value pair
+ ((pair? return-value)
+ ;; compare value with end-key and only yield if within range
+ (if (>= 0 (mdb-cmp txn (lmdb-db-dbi db) (car return-value) end-key-val))
+ (begin
+ ;; yield key-value pair
+ (yield (cons (mdb-val-data (car return-value))
+ (mdb-val-data (cdr return-value))))
+ ;; loop with next value
+ (next (mdb-cursor-get cursor MDB_NEXT)))
+ (mdb-txn-abort txn)))
+
+ ;; no value found, end generator
+ ((equal? MDB_NOTFOUND return-value)
+ (mdb-txn-abort txn))
+
+ ;; unexpected return code, raise an error
+ ((integer? return-value)
+ (mdb-txn-abort txn)
+ (raise-lmdb-error return-value))))))))
diff --git a/lmdb/low-level.scm b/lmdb/low-level.scm
index 3bd1b19..7cb14d2 100644
--- a/lmdb/low-level.scm
+++ b/lmdb/low-level.scm
@@ -84,7 +84,9 @@
MDB_PREV_NODUP
MDB_SET
MDB_SET_KEY
- MDB_SET_RANGE))
+ MDB_SET_RANGE
+
+ mdb-cmp))
;; Return codes
@@ -396,24 +398,47 @@
(define (mdb-cursor-set cursor key op)
"Retrieve by cursor with MDB_SET* operation that requires a key to be specified"
- (let ((proc (liblmdb-func "mdb_cursor_get"
+ (let* ((proc (liblmdb-func "mdb_cursor_get"
+ (list
+ ;; MDB_cursor* cursor
+ '*
+ ;; MDB_val* key
+ '*
+ ;; MDB_val* data
+ '*
+ ;; MDB_cursor_op op
+ unsigned-int)))
+ ;; create a new pointer for returned data
+ (data-ptr (bytevector->pointer
+ (make-bytevector (sizeof '*))))
+ ;; call mdb_cursor_get
+ (return-value (proc (unwrap-mdb-cursor cursor)
+ (unwrap-mdb-val key)
+ data-ptr
+ op)))
+
+ (if (eqv? MDB_SUCCESS return-value)
+ ;; return key and data in order to have same API as mdb-cursort-get
+ (cons key (wrap-mdb-val data-ptr))
+ return-value)))
+
+;;
+
+(define (mdb-cmp txn dbi a b)
+ (let ((proc (liblmdb-func "mdb_cmp"
(list
- ;; MDB_cursor* cursor
- '*
- ;; MDB_val* key
+ ;; MDB_txn* txn
'*
- ;; MDB_val* data
+ ;; MDB_dbi dbi
+ unsigned-int
+ ;; const MDB_val* a
'*
- ;; MDB_cursor_op op
- unsigned-int)))
- (data-ptr (bytevector->pointer
- (make-bytevector (sizeof '*)))))
-
- ;; call mdb_cursor_get
- (proc (unwrap-mdb-cursor cursor)
- (unwrap-mdb-val key)
- data-ptr
- op)))
+ ;; const MDB_val* b
+ '*))))
+ (proc (unwrap-mdb-txn txn)
+ dbi
+ (unwrap-mdb-val a)
+ (unwrap-mdb-val b))))
;; (define env (mdb-env-create))
diff --git a/tests/lmdb.scm b/tests/lmdb.scm
new file mode 100644
index 0000000..c5b6259
--- /dev/null
+++ b/tests/lmdb.scm
@@ -0,0 +1,77 @@
+; SPDX-FileCopyrightText: 2021 pukkamustard <pukkamustard@posteo.net>
+;
+; SPDX-License-Identifier: GPL-3.0-or-later
+
+(define-module (tests lmdb)
+
+ #:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-64)
+ #:use-module (srfi srfi-158)
+ #:use-module (srfi srfi-171)
+
+ #:use-module (lmdb))
+
+(test-begin "Guile LMDB interface")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Setup
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Create a temporary directory
+(define db-dir "./tests/data/db")
+(system* "mkdir" "-p" db-dir)
+
+;; Open database
+(define db (lmdb-open db-dir))
+(test-assert (lmdb-db? db))
+
+;; no value for "Hello"
+(test-assert (not (lmdb-get db (string->utf8 "Hello"))))
+
+;; insert value for "Hello"
+(test-assert (lmdb-put! db (string->utf8 "Hello") (string->utf8 "LMDB!")))
+
+(test-equal "LMDB!"
+ (utf8->string (lmdb-get db (string->utf8 "Hello"))))
+
+;; delete key
+(test-assert (lmdb-delete! db (string->utf8 "Hello")))
+
+;; no value for "Hello"
+(test-assert (not (lmdb-get db (string->utf8 "Hello"))))
+
+;; Range
+
+;; add two ranges of entries
+(for-each (lambda (i)
+ (lmdb-put! db
+ (u8-list->bytevector (list 0 i))
+ (u8-list->bytevector (list i)))
+ (lmdb-put! db
+ (u8-list->bytevector (list 1 i))
+ (u8-list->bytevector (list i))))
+ (iota 32))
+
+;; TODO check that the correct ranges are returned
+(test-eqv 32 (generator-transduce
+ (tmap identity)
+ rcount
+ (lmdb-range db (make-bytevector 1 0) (make-bytevector 1 1))))
+
+(test-eqv 32 (generator-transduce
+ (tmap identity)
+ rcount
+ (lmdb-range db (make-bytevector 1 1) (make-bytevector 1 2))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Close DB and clean up
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; close the environment
+(lmdb-close db)
+
+;; clean up the directory
+(system (string-append "rm -rf " db-dir))
+
+(test-end "Guile LMDB interface")
diff --git a/tests/lmdb/low-level.scm b/tests/lmdb/low-level.scm
index 1a079e7..ae584f3 100644
--- a/tests/lmdb/low-level.scm
+++ b/tests/lmdb/low-level.scm
@@ -98,6 +98,38 @@
;; Abort transaction
(mdb-txn-abort txn)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Compare values
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Begin a new transaction
+(define txn (mdb-txn-begin env))
+(test-assert (mdb-txn? txn))
+
+(test-eqv 0 (mdb-cmp txn dbi
+ (make-mdb-val (u8-list->bytevector '(0)))
+ (make-mdb-val (u8-list->bytevector '(0)))))
+
+(test-assert (> 0 (mdb-cmp txn dbi
+ (make-mdb-val (u8-list->bytevector '(0)))
+ (make-mdb-val (u8-list->bytevector '(1))))))
+
+(test-assert (> 0 (mdb-cmp txn dbi
+ (make-mdb-val (u8-list->bytevector '(0)))
+ (make-mdb-val (u8-list->bytevector '(0 1))))))
+
+(test-assert (< 0 (mdb-cmp txn dbi
+ (make-mdb-val (u8-list->bytevector '(0 1)))
+ (make-mdb-val (u8-list->bytevector '(0))))))
+
+(test-assert (< 0 (mdb-cmp txn dbi
+ (make-mdb-val (u8-list->bytevector '(1)))
+ (make-mdb-val (u8-list->bytevector '(0))))))
+
+;; Abort transaction
+(mdb-txn-abort txn)
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Cursor
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -133,6 +165,7 @@
count
(next (1+ count))))))
+
;; Abort transaction
(mdb-txn-abort txn)