summaryrefslogtreecommitdiff
path: root/lmdb/internal.scm.in
blob: eb046563728d1099a1e5b477e3eced0f59e26aa0 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
; SPDX-FileCopyrightText: 2021 pukkamustard <pukkamustard@posteo.net>
;
; SPDX-License-Identifier: GPL-3.0-or-later

(define-module (lmdb internal)
  #:use-module (system foreign)

  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)

  #:export (liblmdb

            lmdb-error?
            lmdb-error-function-name
            lmdb-error-code
            lmdb-error-description

            liblmdb-func
            liblmdb-void-func))

;; Internal helpers

(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))))

(define (liblmdb-void-func name arg-types)
  (pointer->procedure void
                      (dynamic-func name liblmdb)
                      arg-types))