summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorpukkamustard <pukkamustard@posteo.net>2021-01-07 17:03:06 +0100
committerpukkamustard <pukkamustard@posteo.net>2021-01-07 17:05:39 +0100
commitccf94fc2ca2e4917c9731f2ea464f4d9a63f0439 (patch)
treee18c1fff0a2fd79001109d52fd8d712e723e57c9
parent9209f548c73fca274c64a168a1244d70466c5fdf (diff)
move error handling to (lmdb)
-rw-r--r--README.org20
-rw-r--r--lmdb.scm90
-rw-r--r--lmdb/internal.scm.in36
-rw-r--r--lmdb/low-level.scm263
4 files changed, 321 insertions, 88 deletions
diff --git a/README.org b/README.org
index b02eef7..8b242cb 100644
--- a/README.org
+++ b/README.org
@@ -8,6 +8,24 @@ Guile bindings to the Lightning Memory-Mapped Database (LMDB).
#+BEGIN_SRC scheme
+(use-modules (lmdb)
+ (rnrs bytevectors))
+
+(define db (lmdb-open "./testdb"))
+
+(lmdb-put! db
+ (string->utf8 "Hello")
+ (string->utf8 "guile-lmdb!"))
+
+(lmdb-get db (string->utf8 "Hello"))
+
+(lmdb-delete! db (string->utf8 "Hello"))
+#+END_SRC
+
+
+#+BEGIN_SRC scheme
+(use-modules (lmdb low-level))
+
(define env (mdb-env-create))
(mdb-env? env)
@@ -33,4 +51,4 @@ Guile bindings to the Lightning Memory-Mapped Database (LMDB).
(mdb-txn-abort txn)
(mdb-env-close env)
-#+END_SRc
+#+END_SRC
diff --git a/lmdb.scm b/lmdb.scm
index 8c4982d..1adda34 100644
--- a/lmdb.scm
+++ b/lmdb.scm
@@ -4,7 +4,37 @@
(define-module (lmdb)
#:use-module (srfi srfi-9)
- #:use-module (lmdb low-level))
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+
+ #:use-module (rnrs io ports)
+
+ #:use-module (lmdb low-level)
+
+ #:export (&lmdb-error
+ lmdb-error?
+ lmdb-error-function-name
+ lmdb-error-code
+ lmdb-error-description
+
+ <lmdb-db>
+ lmdb-db?
+ lmdb-open))
+
+;; Error handling
+
+(define-condition-type &lmdb-error
+ &error
+ lmdb-error?
+ (code lmdb-error-code))
+
+(define (raise-lmdb-error code)
+ (raise
+ (make-compound-condition
+ (make-condition &lmdb-error 'code code)
+ (make-condition &message 'message (mdb-strerror code)))))
+
+;; DB handle
(define-record-type <lmdb-db>
(&make-lmdb-db env dbi closed?)
@@ -36,36 +66,42 @@
(define lmdb-transaction?
mdb-txn?)
+(define (call-with-txn db-or-txn proc)
+ (if (mdb-txn? db-or-txn)
+ (proc db-or-txn)
+ (let* ((txn (mdb-txn-begin (lmdb-db-env db-or-txn)))
+ (return-value (proc txn)))
+ (mdb-txn-commit txn)
+ return-value)))
+
+
(define (lmdb-put! db key value)
- (let ((txn (mdb-txn-begin (lmdb-db-env db))))
- (mdb-put txn (lmdb-db-dbi db)
- (make-mdb-val key)
- (make-mdb-val value))
- (mdb-txn-commit txn)))
+ (case (call-with-txn db
+ (lambda (txn) (mdb-put txn (lmdb-db-dbi db)
+ (make-mdb-val key)
+ (make-mdb-val value))))
+ ((MDB_SUCCESS) #t)
+ (else => raise-lmdb-error)))
(define (lmdb-get db key)
- (let* ((txn (mdb-txn-begin (lmdb-db-env db)))
- (val (mdb-get txn (lmdb-db-dbi db)
- (make-mdb-val key))))
- (mdb-txn-abort txn)
- (mdb-val-data val)))
+ (let ((return-value
+ (call-with-txn db (lambda (txn)
+ (mdb-get txn (lmdb-db-dbi db)
+ (make-mdb-val key))))))
+ (cond
+ ((mdb-val? return-value) (mdb-val-data return-value))
+ ((eqv? return-value MDB_NOTFOUND) #f)
+ (else (raise-lmdb-error return-value)))))
(define (lmdb-delete! db key)
- (let ((txn (mdb-txn-begin (lmdb-db-env db))))
- (mdb-del txn (lmdb-db-dbi db)
- (make-mdb-val key))
- (mdb-txn-commit txn)))
-
-(define db (lmdb-open "./testdb"))
-
-(lmdb-db? db)
-
-(use-modules (rnrs bytevectors))
-
-(lmdb-put! db
- (string->utf8 "hi")
- (string->utf8 "blupsblups"))
+ (let ((return-value
+ (call-with-txn db (lambda (txn)
+ (mdb-del txn (lmdb-db-dbi db)
+ (make-mdb-val key))))))
+ (cond
+ ((eqv? return-value MDB_SUCCESS) #t)
+ ((eqv? return-value MDB_NOTFOUND) #f)
+ (else (raise-lmdb-error return-value)))))
-(lmdb-get db (string->utf8 "hi"))
-(lmdb-delete! db (string->utf8 "hi"))
+;; (lmdb-delete! db (string->utf8 "hi"))
diff --git a/lmdb/internal.scm.in b/lmdb/internal.scm.in
index eb04656..c48b33e 100644
--- a/lmdb/internal.scm.in
+++ b/lmdb/internal.scm.in
@@ -10,11 +10,6 @@
#:export (liblmdb
- lmdb-error?
- lmdb-error-function-name
- lmdb-error-code
- lmdb-error-description
-
liblmdb-func
liblmdb-void-func))
@@ -22,37 +17,12 @@
(define liblmdb (dynamic-link "@LIBLMDB_LIBDIR@/liblmdb"))
-;; Error handling
-
-(define-condition-type &lmdb-error
- &error
- lmdb-error?
- (function-name lmdb-error-function-name)
- (code lmdb-error-code)
- (description lmdb-error-description))
-
-(define (mdb-strerror err)
- "Return a string describing a given error code."
- (let ((proc (pointer->procedure '*
- (dynamic-func "mdb_strerror" liblmdb)
- (list int))))
- (pointer->string (proc err))))
-
;; Helper for calling lmdb functions
(define (liblmdb-func name arg-types)
- (let ((proc (pointer->procedure int
- (dynamic-func name liblmdb)
- arg-types)))
- (lambda* (#:rest args)
- (let ((return-value (apply proc args)))
- (unless (= 0 return-value)
- (raise
- (condition (&lmdb-error
- (function-name name)
- (code return-value)
- (description (mdb-strerror return-value))))))
- return-value))))
+ (pointer->procedure int
+ (dynamic-func name liblmdb)
+ arg-types))
(define (liblmdb-void-func name arg-types)
(pointer->procedure void
diff --git a/lmdb/low-level.scm b/lmdb/low-level.scm
index 30ddba6..daede93 100644
--- a/lmdb/low-level.scm
+++ b/lmdb/low-level.scm
@@ -14,7 +14,30 @@
#:use-module (lmdb internal)
- #:export (<mdb-env>
+ #:export (MDB_SUCCESS
+ MDB_KEYEXIST
+ MDB_NOTFOUND
+ MDB_PAGE_NOTFOUND
+ MDB_CORRUPTED
+ MDB_PANIC
+ MDB_VERSION_MISMATCH
+ MDB_INVALID
+ MDB_MAP_FULL
+ MDB_DBS_FULL
+ MDB_READERS_FULL
+ MDB_TLS_FULL
+ MDB_TXN_FULL
+ MDB_CURSOR_FULL
+ MDB_PAGE_FULL
+ MDB_MAP_RESIZED
+ MDB_INCOMPATIBLE
+ MDB_BAD_RSLOT
+ MDB_BAD_TXN
+ MDB_BAD_VALSIZE
+ MDB_BAD_DBI
+ mdb-strerror
+
+ <mdb-env>
mdb-env?
mdb-env-create
mdb-env-open
@@ -37,7 +60,62 @@
mdb-put
mdb-get
- mdb-del))
+ mdb-del
+
+ <mdb-cursor>
+ mdb-cursor?
+ mdb-cursor-open
+ mdb-cursor-get
+ mdb-cursor-set
+ MDB_FIRST
+ MDB_FIRST_DUB
+ MDB_GET_BOTH
+ MDB_GET_BOTH_RANGE
+ MDB_GET_CURRENT
+ MDB_GET_MULTIPLE
+ MDB_LAST
+ MDB_LAST_DUB
+ MDB_NEXT
+ MDB_NEXT_DUP
+ MDB_NEXT_MULTIPLE
+ MDB_NEXT_NODUP
+ MDB_PREV
+ MDB_PREV_DUP
+ MDB_PREV_NODUP
+ MDB_SET
+ MDB_SET_KEY
+ MDB_SET_RANGE))
+
+;; Return codes
+
+(define MDB_SUCCESS 0)
+(define MDB_KEYEXIST -30799)
+(define MDB_NOTFOUND -30798)
+(define MDB_PAGE_NOTFOUND -30797)
+(define MDB_CORRUPTED -30796)
+(define MDB_PANIC -30795)
+(define MDB_VERSION_MISMATCH -30794)
+(define MDB_INVALID -30793)
+(define MDB_MAP_FULL -30792)
+(define MDB_DBS_FULL -30791)
+(define MDB_READERS_FULL -30790)
+(define MDB_TLS_FULL -30789)
+(define MDB_TXN_FULL -30788)
+(define MDB_CURSOR_FULL -30787)
+(define MDB_PAGE_FULL -30786)
+(define MDB_MAP_RESIZED -30785)
+(define MDB_INCOMPATIBLE -30784)
+(define MDB_BAD_RSLOT -30783)
+(define MDB_BAD_TXN -30782)
+(define MDB_BAD_VALSIZE -30781)
+(define MDB_BAD_DBI -30780)
+
+(define (mdb-strerror err)
+ "Return a string describing a given error code."
+ (let ((proc (pointer->procedure '*
+ (dynamic-func "mdb_strerror" liblmdb)
+ (list int))))
+ (pointer->string (proc err))))
;; MDB_env
@@ -126,14 +204,6 @@
;; 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
@@ -152,8 +222,9 @@
(make-pointer 0)
0
dbi-ptr)
- ;; wrap pointer as <mdb-dbi>
- (wrap-mdb-dbi (dereference-pointer dbi-ptr))))
+ ;; dbi is an unsigned integer
+ (pointer-address (dereference-pointer dbi-ptr))))
+
;; MDB_val
@@ -183,8 +254,8 @@
(list
;; MDB_txn* txn
'*
- ;; MDB_dbi* dbi
- '*
+ ;; MDB_dbi dbi
+ unsigned-int
;; MDB_val* key
'*
;; MDB_val* data
@@ -192,7 +263,7 @@
;; unsigned int flags
unsigned-int))))
(proc (unwrap-mdb-txn txn)
- (unwrap-mdb-dbi dbi)
+ dbi
(unwrap-mdb-val key)
(unwrap-mdb-val data)
0)))
@@ -203,21 +274,23 @@
(list
;; MDB_txn* txn
'*
- ;; MDB_dbi* dbi
- '*
+ ;; MDB_dbi dbi
+ unsigned-int
;; 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)))
+ (let ((return-value (proc (unwrap-mdb-txn txn)
+ dbi
+ (unwrap-mdb-val key)
+ data-ptr)))
+ (if (eqv? 0 return-value)
+ ;; wrap data as <mdb-val>
+ (wrap-mdb-val data-ptr)
+ ;; else return the return value
+ return-value))))
(define (mdb-del txn dbi key)
"Delete items from a database"
@@ -225,13 +298,149 @@
(list
;; MDB_txn* txn
'*
- ;; MDB_dbi* dbi
- '*
+ ;; MDB_dbi dbi
+ unsigned-int
;; MDB_val* key
'*
;; MDB_val* data
'*))))
(proc (unwrap-mdb-txn txn)
- (unwrap-mdb-dbi dbi)
+ dbi
(unwrap-mdb-val key)
(make-pointer 0))))
+
+;; Cursor
+
+(define-wrapped-pointer-type <mdb-cursor>
+ mdb-cursor?
+ wrap-mdb-cursor unwrap-mdb-cursor
+ (lambda (cursor port)
+ (format port "#<mdb-cursor ~x>"
+ (pointer-address (unwrap-mdb-cursor cursor)))))
+
+
+;; enum MDB_cursor_op
+(define MDB_FIRST 0)
+(define MDB_FIRST_DUB 1)
+(define MDB_GET_BOTH 2)
+(define MDB_GET_BOTH_RANGE 3)
+(define MDB_GET_CURRENT 4)
+(define MDB_GET_MULTIPLE 5)
+(define MDB_LAST 6)
+(define MDB_LAST_DUB 7)
+(define MDB_NEXT 8)
+(define MDB_NEXT_DUP 9)
+(define MDB_NEXT_MULTIPLE 10)
+(define MDB_NEXT_NODUP 11)
+(define MDB_PREV 12)
+(define MDB_PREV_DUP 13)
+(define MDB_PREV_NODUP 14)
+(define MDB_SET 15)
+(define MDB_SET_KEY 16)
+(define MDB_SET_RANGE 17)
+
+(define (mdb-cursor-open txn dbi)
+ "Create a cursor handle"
+ (let ((proc (liblmdb-func "mdb_cursor_open"
+ (list
+ ;; MDB_txn* txn
+ '*
+ ;; MDB_dbi dbi
+ unsigned-int
+ ;; MDB_cursor** cursor
+ '*)))
+ (cursor-ptr (bytevector->pointer
+ (make-bytevector (sizeof '*)))))
+ (proc (unwrap-mdb-txn txn)
+ dbi
+ cursor-ptr)
+ (wrap-mdb-cursor (dereference-pointer cursor-ptr))))
+
+(define (mdb-cursor-close cursor)
+ "Close a cursor handle"
+ (let ((proc (liblmdb-void-func "mdb_cursor_close"
+ (list
+ ;; MDB_cursor* cursor
+ cursor))))
+ (proc (unwrap-mdb-cursor cursor))))
+
+(define (mdb-cursor-get cursor op)
+ "Retrieve by cursor"
+ (let ((proc (liblmdb-func "mdb_cursor_get"
+ (list
+ ;; MDB_cursor* cursor
+ '*
+ ;; MDB_val* key
+ '*
+ ;; MDB_val* data
+ '*
+ ;; MDB_cursor_op op
+ unsigned-int)))
+ (key-ptr (bytevector->pointer
+ (make-bytevector (sizeof '*))))
+ (data-ptr (bytevector->pointer
+ (make-bytevector (sizeof '*)))))
+
+ ;; call mdb_cursor_get
+ (proc (unwrap-mdb-cursor cursor)
+ key-ptr
+ data-ptr
+ op)
+
+ ;; wrap key and data as <mdb-val>
+ (values (wrap-mdb-val key-ptr)
+ (wrap-mdb-val data-ptr))))
+
+(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"
+ (list
+ ;; MDB_cursor* cursor
+ '*
+ ;; MDB_val* key
+ '*
+ ;; MDB_val* data
+ '*
+ ;; 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)
+
+ ;; wrap data as <mdb-val>
+ (wrap-mdb-val data-ptr)))
+
+;; (define env (mdb-env-create))
+
+;; (mdb-env? env)
+
+;; (mdb-env-open env "../testdb")
+
+;; (define txn (mdb-txn-begin env))
+
+;; (mdb-txn? txn)
+
+;; (define dbi (mdb-dbi-open txn))
+
+;; (+ 0 dbi)
+
+;; (mdb-txn-abort txn)
+
+;; (define txn (mdb-txn-begin env))
+
+;; (mdb-get txn dbi (make-mdb-val (string->utf8 "Hello")))
+
+;; (mdb-txn-abort txn)
+
+;; (define txn (mdb-txn-begin env))
+
+;; (define cursor (mdb-cursor-open txn dbi))
+
+;; (mdb-cursor-get cursor MDB_NEXT)
+
+;; (mdb-txn-abort txn)