summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorpukkamustard <pukkamustard@posteo.net>2021-01-05 19:22:58 +0100
committerpukkamustard <pukkamustard@posteo.net>2021-01-05 19:22:58 +0100
commita511b34a91b24509fb61c1d44a50a6b6ea485171 (patch)
tree26be7fd36af41b1b3cc942172fee2fc2f45e4786
parentbb70868957e0600ed5c6c393076338371637885b (diff)
lmdb.scm -> lmdb/low-level.scm
-rw-r--r--Makefile.am3
-rw-r--r--hall.scm3
-rw-r--r--lmdb.scm191
-rw-r--r--lmdb/low-level.scm195
4 files changed, 200 insertions, 192 deletions
diff --git a/Makefile.am b/Makefile.am
index 93515f1..64ca8a7 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -35,7 +35,8 @@ SUFFIXES = .scm .go
$(AM_V_GEN)$(top_builddir)/pre-inst-env $(GUILE_TOOLS) compile $(GUILE_WARNINGS) -o "$@" "$<"
SOURCES = lmdb.scm \
- lmdb/internal.scm
+ lmdb/internal.scm \
+ lmdb/low-level.scm
TESTS =
diff --git a/hall.scm b/hall.scm
index 20eceed..3d8c9ed 100644
--- a/hall.scm
+++ b/hall.scm
@@ -11,7 +11,8 @@
(dependencies `())
(files (libraries
((scheme-file "lmdb")
- (directory "lmdb" ((scheme-file "internal")))))
+ (directory "lmdb" ((scheme-file "internal")
+ (scheme-file "low-level")))))
(tests ((directory "tests" ())))
(programs ((directory "scripts" ())))
(documentation
diff --git a/lmdb.scm b/lmdb.scm
index da34190..e933e20 100644
--- a/lmdb.scm
+++ b/lmdb.scm
@@ -3,193 +3,4 @@
; SPDX-License-Identifier: GPL-3.0-or-later
(define-module (lmdb)
- #:use-module (system foreign)
-
- #:use-module (ice-9 format)
-
- #:use-module (srfi srfi-34)
- #:use-module (srfi srfi-35)
-
- #:use-module (rnrs bytevectors)
-
- #:use-module (lmdb internal))
-
-;; MDB_env
-
-(define-wrapped-pointer-type <mdb-env>
- mdb-env?
- wrap-mdb-env unwrap-mdb-env
- (lambda (mdb-env port)
- (format port "#<mdb-env ~x>"
- (pointer-address (unwrap-mdb-env mdb-env)))))
-
-(define (mdb-env-create)
- "Create an LMDB environment handle"
- (let ((proc (liblmdb-func "mdb_env_create" (list '*)))
- (mdb-env-ptr (bytevector->pointer
- (make-bytevector (sizeof '*) 0))))
- ;; call mdb_env_create
- (proc mdb-env-ptr)
- ;; wrap returned pointer as <mdb-env>
- (wrap-mdb-env (dereference-pointer mdb-env-ptr))))
-
-(define (mdb-env-open mdb-env path)
- "Open an environment handle"
- (let ((proc (liblmdb-func "mdb_env_open"
- (list
- ;; MDB_env* env
- '*
- ;; char* path
- '*
- ;; unsigned int flags
- unsigned-int
- ;; mdb_mode_t mode (int)
- int))))
- (proc (unwrap-mdb-env mdb-env) (string->pointer path) 0 #o644)))
-
-(define (mdb-env-close mdb-env)
- "Close the environment and release the memory map"
- (let ((proc (liblmdb-void-func "mdb_env_close" (list '*))))
- (proc (unwrap-mdb-env mdb-env))))
-
-;; MDB_txn
-
-(define-wrapped-pointer-type <mdb-txn>
- mdb-txn?
- wrap-mdb-txn unwrap-mdb-txn
- (lambda (mdb-txn port)
- (format port "#<mdb-txn ~x>"
- (pointer-address (unwrap-mdb-txn mdb-txn)))))
-
-(define (mdb-txn-begin env)
- "Create a transaction for use with the environment"
- (let ((proc (liblmdb-func "mdb_txn_begin"
- (list
- ;; MDB_env* env
- '*
- ;; MDB_txn* parent
- '*
- ;; unsigned int flags
- unsigned-int
- ;; MDB_txn** txn
- '*)))
-
- ;; allocate a new pointer for returned txn
- (txn-ptr (bytevector->pointer
- (make-bytevector (sizeof '*)))))
-
- ;; call mdb_txn_begin
- (proc (unwrap-mdb-env env)
- ;; TODO allow specifying parent txn
- (make-pointer 0)
- 0
- txn-ptr)
-
- ;; wrap pointer as <mdb-txn>
- (wrap-mdb-txn (dereference-pointer txn-ptr))))
-
-
-(define (mdb-txn-abort txn)
- "Abandon all the operations of the transaction instead of saving them"
- (let ((proc (liblmdb-void-func "mdb_txn_abort" (list '*))))
- (proc (unwrap-mdb-txn txn))))
-
-(define (mdb-txn-commit txn)
- "Commit all the operations of a transaction into the database"
- (let ((proc (liblmdb-func "mdb_txn_commit" (list '*))))
- (proc (unwrap-mdb-txn txn))))
-
-;; MDB_dbi
-
-(define-wrapped-pointer-type <mdb-dbi>
- mdb-dbi?
- wrap-mdb-dbi unwrap-mdb-dbi
- (lambda (mdb-dbi port)
- (format port "#<mdb-dbi ~x>"
- (pointer-address (unwrap-mdb-dbi mdb-dbi)))))
-
-
-(define (mdb-dbi-open txn)
- (let ((proc (liblmdb-func "mdb_dbi_open"
- (list
- ;; MDB_txn* txn
- '*
- ;; const char* name
- '*
- ;; unsigned int flags
- unsigned-int
- ;; MDB_dbi* dbi
- '*)))
- (dbi-ptr (bytevector->pointer
- (make-bytevector (sizeof '*)))))
- (proc (unwrap-mdb-txn txn)
- ;; null pointer TODO allow specifying name
- (make-pointer 0)
- 0
- dbi-ptr)
- ;; wrap pointer as <mdb-dbi>
- (wrap-mdb-dbi (dereference-pointer dbi-ptr))))
-
-
-;; MDB_val
-
-(define-wrapped-pointer-type <mdb-val>
- mdb-val?
- wrap-mdb-val unwrap-mdb-val
- (lambda (mdb-val port)
- (format port "#<mdb-val ~x>"
- (pointer-address (unwrap-mdb-val mdb-val)))))
-
-(define (make-mdb-val value)
- (wrap-mdb-val (make-c-struct (list size_t '*)
- (list (bytevector-length value)
- (bytevector->pointer value)))))
-
-(define (mdb-val-data val)
- (let ((size-data-ptr (parse-c-struct (unwrap-mdb-val val) (list size_t '*))))
- (pointer->bytevector (cadr size-data-ptr)
- (car size-data-ptr))))
-
-;; put and get
-
-(define (mdb-put txn dbi key data)
- "Store items into a database."
- (let ((proc (liblmdb-func "mdb_put"
- (list
- ;; MDB_txn* txn
- '*
- ;; MDB_dbi* dbi
- '*
- ;; MDB_val* key
- '*
- ;; MDB_val* data
- '*
- ;; unsigned int flags
- unsigned-int))))
- (proc (unwrap-mdb-txn txn)
- (unwrap-mdb-dbi dbi)
- (unwrap-mdb-val key)
- (unwrap-mdb-val data)
- 0)))
-
-(define (mdb-get txn dbi key)
- "Store items into a database."
- (let ((proc (liblmdb-func "mdb_get"
- (list
- ;; MDB_txn* txn
- '*
- ;; MDB_dbi* dbi
- '*
- ;; MDB_val* key
- '*
- ;; MDB_val* data
- '*)))
- (data-ptr (bytevector->pointer
- (make-bytevector (sizeof '*)))))
- ;; call mdb_get
- (proc (unwrap-mdb-txn txn)
- (unwrap-mdb-dbi dbi)
- (unwrap-mdb-val key)
- data-ptr)
- ;; wrap data as <mdb-val>
- (wrap-mdb-val data-ptr)))
+ #:use-module (lmdb low-level))
diff --git a/lmdb/low-level.scm b/lmdb/low-level.scm
new file mode 100644
index 0000000..56bdf49
--- /dev/null
+++ b/lmdb/low-level.scm
@@ -0,0 +1,195 @@
+; SPDX-FileCopyrightText: 2021 pukkamustard <pukkamustard@posteo.net>
+;
+; SPDX-License-Identifier: GPL-3.0-or-later
+
+(define-module (lmdb low-level)
+ #:use-module (system foreign)
+
+ #:use-module (ice-9 format)
+
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+
+ #:use-module (rnrs bytevectors)
+
+ #:use-module (lmdb internal))
+
+;; MDB_env
+
+(define-wrapped-pointer-type <mdb-env>
+ mdb-env?
+ wrap-mdb-env unwrap-mdb-env
+ (lambda (mdb-env port)
+ (format port "#<mdb-env ~x>"
+ (pointer-address (unwrap-mdb-env mdb-env)))))
+
+(define (mdb-env-create)
+ "Create an LMDB environment handle"
+ (let ((proc (liblmdb-func "mdb_env_create" (list '*)))
+ (mdb-env-ptr (bytevector->pointer
+ (make-bytevector (sizeof '*) 0))))
+ ;; call mdb_env_create
+ (proc mdb-env-ptr)
+ ;; wrap returned pointer as <mdb-env>
+ (wrap-mdb-env (dereference-pointer mdb-env-ptr))))
+
+(define (mdb-env-open mdb-env path)
+ "Open an environment handle"
+ (let ((proc (liblmdb-func "mdb_env_open"
+ (list
+ ;; MDB_env* env
+ '*
+ ;; char* path
+ '*
+ ;; unsigned int flags
+ unsigned-int
+ ;; mdb_mode_t mode (int)
+ int))))
+ (proc (unwrap-mdb-env mdb-env) (string->pointer path) 0 #o644)))
+
+(define (mdb-env-close mdb-env)
+ "Close the environment and release the memory map"
+ (let ((proc (liblmdb-void-func "mdb_env_close" (list '*))))
+ (proc (unwrap-mdb-env mdb-env))))
+
+;; MDB_txn
+
+(define-wrapped-pointer-type <mdb-txn>
+ mdb-txn?
+ wrap-mdb-txn unwrap-mdb-txn
+ (lambda (mdb-txn port)
+ (format port "#<mdb-txn ~x>"
+ (pointer-address (unwrap-mdb-txn mdb-txn)))))
+
+(define (mdb-txn-begin env)
+ "Create a transaction for use with the environment"
+ (let ((proc (liblmdb-func "mdb_txn_begin"
+ (list
+ ;; MDB_env* env
+ '*
+ ;; MDB_txn* parent
+ '*
+ ;; unsigned int flags
+ unsigned-int
+ ;; MDB_txn** txn
+ '*)))
+
+ ;; allocate a new pointer for returned txn
+ (txn-ptr (bytevector->pointer
+ (make-bytevector (sizeof '*)))))
+
+ ;; call mdb_txn_begin
+ (proc (unwrap-mdb-env env)
+ ;; TODO allow specifying parent txn
+ (make-pointer 0)
+ 0
+ txn-ptr)
+
+ ;; wrap pointer as <mdb-txn>
+ (wrap-mdb-txn (dereference-pointer txn-ptr))))
+
+
+(define (mdb-txn-abort txn)
+ "Abandon all the operations of the transaction instead of saving them"
+ (let ((proc (liblmdb-void-func "mdb_txn_abort" (list '*))))
+ (proc (unwrap-mdb-txn txn))))
+
+(define (mdb-txn-commit txn)
+ "Commit all the operations of a transaction into the database"
+ (let ((proc (liblmdb-func "mdb_txn_commit" (list '*))))
+ (proc (unwrap-mdb-txn txn))))
+
+;; MDB_dbi
+
+(define-wrapped-pointer-type <mdb-dbi>
+ mdb-dbi?
+ wrap-mdb-dbi unwrap-mdb-dbi
+ (lambda (mdb-dbi port)
+ (format port "#<mdb-dbi ~x>"
+ (pointer-address (unwrap-mdb-dbi mdb-dbi)))))
+
+
+(define (mdb-dbi-open txn)
+ (let ((proc (liblmdb-func "mdb_dbi_open"
+ (list
+ ;; MDB_txn* txn
+ '*
+ ;; const char* name
+ '*
+ ;; unsigned int flags
+ unsigned-int
+ ;; MDB_dbi* dbi
+ '*)))
+ (dbi-ptr (bytevector->pointer
+ (make-bytevector (sizeof '*)))))
+ (proc (unwrap-mdb-txn txn)
+ ;; null pointer TODO allow specifying name
+ (make-pointer 0)
+ 0
+ dbi-ptr)
+ ;; wrap pointer as <mdb-dbi>
+ (wrap-mdb-dbi (dereference-pointer dbi-ptr))))
+
+
+;; MDB_val
+
+(define-wrapped-pointer-type <mdb-val>
+ mdb-val?
+ wrap-mdb-val unwrap-mdb-val
+ (lambda (mdb-val port)
+ (format port "#<mdb-val ~x>"
+ (pointer-address (unwrap-mdb-val mdb-val)))))
+
+(define (make-mdb-val value)
+ (wrap-mdb-val (make-c-struct (list size_t '*)
+ (list (bytevector-length value)
+ (bytevector->pointer value)))))
+
+(define (mdb-val-data val)
+ (let ((size-data-ptr (parse-c-struct (unwrap-mdb-val val) (list size_t '*))))
+ (pointer->bytevector (cadr size-data-ptr)
+ (car size-data-ptr))))
+
+;; put and get
+
+(define (mdb-put txn dbi key data)
+ "Store items into a database."
+ (let ((proc (liblmdb-func "mdb_put"
+ (list
+ ;; MDB_txn* txn
+ '*
+ ;; MDB_dbi* dbi
+ '*
+ ;; MDB_val* key
+ '*
+ ;; MDB_val* data
+ '*
+ ;; unsigned int flags
+ unsigned-int))))
+ (proc (unwrap-mdb-txn txn)
+ (unwrap-mdb-dbi dbi)
+ (unwrap-mdb-val key)
+ (unwrap-mdb-val data)
+ 0)))
+
+(define (mdb-get txn dbi key)
+ "Store items into a database."
+ (let ((proc (liblmdb-func "mdb_get"
+ (list
+ ;; MDB_txn* txn
+ '*
+ ;; MDB_dbi* dbi
+ '*
+ ;; MDB_val* key
+ '*
+ ;; MDB_val* data
+ '*)))
+ (data-ptr (bytevector->pointer
+ (make-bytevector (sizeof '*)))))
+ ;; call mdb_get
+ (proc (unwrap-mdb-txn txn)
+ (unwrap-mdb-dbi dbi)
+ (unwrap-mdb-val key)
+ data-ptr)
+ ;; wrap data as <mdb-val>
+ (wrap-mdb-val data-ptr)))