├── .dist.sh ├── .gitignore ├── .travis-ci.sh ├── .travis.yml ├── LICENSE.md ├── Makefile ├── README.md ├── discover.ml ├── dune ├── dune-project ├── lmdb.opam ├── setup.ml ├── src ├── dune ├── lmdb.ml ├── lmdb.mli ├── lmdb_bindings.ml ├── lmdb_bindings.mli └── lmdb_stubs.c └── tests ├── bench.ml ├── dune ├── pr.ml ├── simple_db.ml └── test.ml /.dist.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # 3 | # dist 4 | # ---- 5 | # Copyright : (c) 2012, Jeremie Dimino 6 | # Licence : BSD3 7 | # 8 | # Script to build the release 9 | 10 | set -e 11 | 12 | # Extract project parameters from _oasis 13 | NAME=`opam show -f name . 2>/dev/null` 14 | VERSION=`opam show -f version . 2>/dev/null` 15 | PREFIX=$NAME-$VERSION 16 | ARCHIVE=$(pwd)/$PREFIX.tar.gz 17 | 18 | # Clean setup.data and other generated files. 19 | dune clean 20 | 21 | # Create a branch for the release 22 | git checkout -b release-$VERSION 23 | 24 | # Remove this script and dev-files 25 | rm -f .dist.sh .travis* 26 | 27 | # Commit 28 | git add --all --force 29 | git commit 30 | git tag $VERSION 31 | 32 | git checkout master 33 | 34 | # Prepare publishing 35 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | .merlin 3 | *.install 4 | -------------------------------------------------------------------------------- /.travis-ci.sh: -------------------------------------------------------------------------------- 1 | if [ "$TRAVIS_OS_NAME" = "linux" ] 2 | then 3 | wget http://mirrors.kernel.org/ubuntu/pool/universe/l/lmdb/liblmdb0_0.9.21-1_amd64.deb 4 | wget http://mirrors.kernel.org/ubuntu/pool/universe/l/lmdb/liblmdb-dev_0.9.21-1_amd64.deb 5 | sudo dpkg -i liblmdb0_0.9.21-1_amd64.deb liblmdb-dev_0.9.21-1_amd64.deb 6 | fi 7 | 8 | export OCAMLRUNPARAM+=b 9 | 10 | bash -ex .travis-opam.sh 11 | 12 | ## Documentation stuff 13 | 14 | set -e 15 | # Make sure we're not echoing any sensitive data 16 | set +x 17 | set -o errexit -o nounset 18 | 19 | if [ -z "$TRAVIS" \ 20 | -o "$TRAVIS_PULL_REQUEST" != "false" \ 21 | -o "$TRAVIS_BRANCH" != "master" \ 22 | -o -z "${DOC+x}" \ 23 | ]; then 24 | echo "This is not a push Travis-ci build, doing nothing..." 25 | exit 0 26 | else 27 | echo "Updating docs on Github pages..." 28 | fi 29 | 30 | eval `opam config env` 31 | opam install lmdb --with-test --with-doc --deps-only --verbose --yes 32 | dune build @doc 33 | 34 | DOCDIR=.gh-pages 35 | 36 | # Error out if $GH_TOKEN is empty or unset 37 | : ${GH_TOKEN:?"GH_TOKEN need to be uploaded via travis-encrypt"} 38 | 39 | git clone https://${GH_TOKEN}@github.com/${TRAVIS_REPO_SLUG} $DOCDIR 2>&1 | sed -e "s/$GH_TOKEN/!REDACTED!/g" 40 | git -C $DOCDIR checkout gh-pages || git -C $DOCDIR checkout --orphan gh-pages 41 | 42 | rm -rf $DOCDIR/dev/* 43 | cp -R _build/default/_doc/_html/* $DOCDIR/dev 44 | 45 | git -C $DOCDIR config user.email "travis@travis-ci.org" 46 | git -C $DOCDIR config user.name "Travis" 47 | git -C $DOCDIR add --all dev 48 | git -C $DOCDIR commit --allow-empty -m "Travis build $TRAVIS_BUILD_NUMBER pushed docs to gh-pages" 49 | git -C $DOCDIR push origin gh-pages 2>&1 | sed -e "s/$GH_TOKEN/!REDACTED!/g" 50 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | dist: xenial 2 | language: c 3 | sudo: required 4 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-opam.sh 5 | script: bash -ex .travis-ci.sh 6 | env: 7 | global: 8 | - PACKAGE=lmdb 9 | - secure: YWrGjdp0SFP1/MS6tB5MXy5QCuGbT+XQOG4eKHERegSiVdTVr/mBKRelmmMiSEpbRHwXpuNfNA4sYFfMsyV+2bf6W0cqQTXeITbm0CewuLxdxN0CZxyfIkcarhHLTq65xiKqWQpVPkjjP6gftmszWMKs2Xev/JwCWS4dbK/oihI= 10 | matrix: 11 | include: 12 | - os: osx 13 | env: OCAML_VERSION=4.07 14 | - os: linux 15 | env: OCAML_VERSION=4.07 DOC=true 16 | - os: linux 17 | env: OCAML_VERSION=4.03 18 | - os: linux 19 | env: OCAML_VERSION=4.04 20 | - os: linux 21 | env: OCAML_VERSION=4.05 22 | - os: linux 23 | env: OCAML_VERSION=4.06 24 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2014 Gabriel Radanne 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: default 2 | default: build 3 | 4 | .PHONY: build 5 | build: 6 | dune build @install 7 | 8 | .PHONY: test 9 | test: 10 | dune runtest 11 | 12 | .PHONY: bench 13 | bench: 14 | dune build --profile=release @bench 15 | 16 | .PHONY: clean 17 | clean: 18 | dune clean 19 | 20 | .PHONY: doc 21 | doc: 22 | dune build @doc 23 | 24 | NAME=lmdb 25 | DOCDIR=.gh-pages 26 | 27 | $(DOCDIR)/.git: 28 | mkdir -p $(DOCDIR) 29 | cd $(DOCDIR) && (\ 30 | git clone -b gh-pages git@github.com:Drup/$(NAME).git . \ 31 | ) 32 | 33 | gh-pages: $(DOCDIR)/.git doc 34 | git -C $(DOCDIR) pull 35 | cp -r _build/default/_doc/_html/* $(DOCDIR)/dev/ 36 | git -C $(DOCDIR) add --all 37 | git -C $(DOCDIR) commit -a -m "gh-page updates" 38 | git -C $(DOCDIR) push origin gh-pages 39 | 40 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # OCaml-lmdb [![Build Status](https://travis-ci.org/Drup/ocaml-lmdb.svg?branch=master)](https://travis-ci.org/Drup/ocaml-lmdb) [![docs](https://img.shields.io/badge/doc-online-blue.svg)][doc] 2 | 3 | The [LMDB][] database is a fast in-file database that supports ACID transactions. 4 | 5 | These bindings expose a typesafe yet low-overhead API. Both transactions and cursors are available. 6 | Database implementations are specialized both by keys and values. 7 | Two module are predefined: `Lmdb.Db` (string keys and string values) and `Lmdb.IntDb` (int keys and string values). 8 | New implementation (which can use special LMDB features such as multi-values) can be added via a functorial interface. 9 | 10 | Please consult the [documentation][doc] and a [simple example](tests/simple_db.ml). 11 | 12 | ```ocaml 13 | let open Lmdb in 14 | let env = Env.(create Rw ~flags:Flags.no_subdir ~max_maps:1) "mydb" in 15 | let map = Map.create Nodup ~key:Conv.string ~value:Conv.string 16 | ~name:"Camelidae" env in 17 | Map.add map "Bactrian camel" "Elegant and beautiful animal with two humps." 18 | ``` 19 | 20 | [lmdb]: http://symas.com/mdb/#overview 21 | [doc]: https://drup.github.io/ocaml-lmdb/dev/lmdb/Lmdb/index.html 22 | -------------------------------------------------------------------------------- /discover.ml: -------------------------------------------------------------------------------- 1 | module C = Configurator.V1 2 | 3 | let split_env var = 4 | try 5 | Str.(split (regexp_string ":")) (Sys.getenv var) 6 | with Not_found -> [] 7 | let include_candidates = 8 | split_env "CPATH" @ 9 | [ "/usr/include" 10 | ; "/usr/local/include" 11 | ; "/opt/include" ] 12 | and lib_candidates = 13 | split_env "LIBRARY_PATH" @ 14 | [ "/lib" 15 | ; "/usr/lib" 16 | ; "/usr/local/lib" 17 | ; "/usr/lib/x86_64-linux-gnu/" 18 | ; "/opt/lib" ] 19 | 20 | 21 | let () = 22 | C.main ~name:"foo" begin fun c -> 23 | let lmdb_pc = 24 | match C.Pkg_config.get c with 25 | | None -> None 26 | | Some pc -> 27 | C.Pkg_config.query pc 28 | ~package:"lmdb" 29 | in 30 | let lmdb = 31 | match lmdb_pc with 32 | | Some lmdb -> lmdb 33 | | None -> 34 | let include_path = 35 | try 36 | List.find 37 | (fun path -> Sys.file_exists (path ^ "/lmdb.h")) 38 | include_candidates 39 | with Not_found -> failwith "lmdb.h not found" 40 | and lib_path = 41 | try 42 | List.find 43 | (fun path -> Sys.file_exists (path ^ "/liblmdb.a")) 44 | lib_candidates 45 | with Not_found -> failwith "liblmdb.a not found" 46 | in 47 | let open C.Pkg_config in 48 | { cflags = [ "-I" ^ include_path ] 49 | ; libs = [ "-L" ^ lib_path; "-llmdb" ] } 50 | in 51 | 52 | C.Flags.write_sexp "cflags.sexp" lmdb.cflags; 53 | C.Flags.write_sexp "clibs.sexp" lmdb.libs 54 | end 55 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name discover) 3 | (modules discover) 4 | (libraries str dune.configurator)) 5 | 6 | (rule 7 | (targets cflags.sexp clibs.sexp) 8 | (action (run ./discover.bc))) 9 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.2) 2 | (name lmdb) 3 | (version 1.1) 4 | -------------------------------------------------------------------------------- /lmdb.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Gabriel Radanne " 3 | synopsis: "Bindings for LMDB, a fast in-file database with ACID transactions" 4 | authors: [ 5 | "Gabriel Radanne " 6 | "Christopher Zimmermann " 7 | ] 8 | license: "MIT" 9 | homepage: "https://github.com/Drup/ocaml-lmdb" 10 | bug-reports: "https://github.com/Drup/ocaml-lmdb/issues" 11 | dev-repo: "git+https://github.com/Drup/ocaml-lmdb.git" 12 | doc: "https://drup.github.io/ocaml-lmdb/dev/lmdb/Lmdb/index.html" 13 | tags: [ "clib:lmdb" "database" ] 14 | build: [ 15 | ["dune" "subst"] {pinned} 16 | ["dune" "build" "-p" name "-j" jobs] 17 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 18 | ] 19 | depends: [ 20 | "ocaml" {>= "4.03"} 21 | "bigstringaf" 22 | "dune" {>= "1.2"} 23 | "dune-configurator" {build} 24 | "alcotest" {with-test} 25 | "benchmark" {with-test} 26 | "odoc" {with-doc} 27 | ] 28 | 29 | depexts: [ 30 | ["liblmdb-dev"] {os-family = "debian"} 31 | ["lmdb"] {os-family = "bsd"} 32 | ["lmdb"] {os-family = "homebrew"} 33 | ["lmdb"] {os-family = "macports"} 34 | ["lmdb"] {os-family = "archlinux"} 35 | ["lmdb"] {os-family = "gentoo"} 36 | ["lmdb-dev"] {os-family = "alpine"} 37 | ["lmdb-devel"] {os-family = "rhel" | os-family = "centos"} 38 | ["lmdb-devel"] {os-family = "fedora"} 39 | ["lmdb-devel"] {os-family = "suse" | os-family = "opensuse"} 40 | ["liblmdb-devel"] {os-family = "mageia"} 41 | ] 42 | -------------------------------------------------------------------------------- /setup.ml: -------------------------------------------------------------------------------- 1 | (* setup.ml generated for the first time by OASIS v0.4.5 *) 2 | 3 | (* OASIS_START *) 4 | (* DO NOT EDIT (digest: 9852805d5c19ca1cb6abefde2dcea323) *) 5 | (******************************************************************************) 6 | (* OASIS: architecture for building OCaml libraries and applications *) 7 | (* *) 8 | (* Copyright (C) 2011-2013, Sylvain Le Gall *) 9 | (* Copyright (C) 2008-2011, OCamlCore SARL *) 10 | (* *) 11 | (* This library is free software; you can redistribute it and/or modify it *) 12 | (* under the terms of the GNU Lesser General Public License as published by *) 13 | (* the Free Software Foundation; either version 2.1 of the License, or (at *) 14 | (* your option) any later version, with the OCaml static compilation *) 15 | (* exception. *) 16 | (* *) 17 | (* This library is distributed in the hope that it will be useful, but *) 18 | (* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *) 19 | (* or FITNESS FOR A PARTICULAR PURPOSE. See the file COPYING for more *) 20 | (* details. *) 21 | (* *) 22 | (* You should have received a copy of the GNU Lesser General Public License *) 23 | (* along with this library; if not, write to the Free Software Foundation, *) 24 | (* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) 25 | (******************************************************************************) 26 | 27 | let () = 28 | try 29 | Topdirs.dir_directory (Sys.getenv "OCAML_TOPLEVEL_PATH") 30 | with Not_found -> () 31 | ;; 32 | #use "topfind";; 33 | #require "oasis.dynrun";; 34 | open OASISDynRun;; 35 | 36 | (* OASIS_STOP *) 37 | let () = setup ();; 38 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name lmdb) 3 | (public_name lmdb) 4 | (synopsis "Bindings for LMDB, a fast in-file database with ACID transactions") 5 | (flags :standard -safe-string -thread) 6 | (libraries unix bigstringaf) 7 | (c_flags 8 | :standard 9 | (:include "%{project_root}/cflags.sexp") 10 | -Wall -Wextra -Wno-unused-parameter -pedantic 11 | ) 12 | (c_names lmdb_stubs) 13 | (c_library_flags (:include "%{project_root}/clibs.sexp")) 14 | ) 15 | -------------------------------------------------------------------------------- /src/lmdb.ml: -------------------------------------------------------------------------------- 1 | module Mdb = Lmdb_bindings 2 | module type Flags = Mdb.Flags 3 | module Bigstring = Bigstringaf 4 | 5 | exception Not_found = Not_found 6 | exception Exists = Mdb.Exists 7 | exception Map_full = Mdb.Map_full 8 | exception Error = Mdb.Error 9 | 10 | type 'a perm = 11 | | Ro : [ `Read ] perm 12 | | Rw : [ `Read | `Write ] perm 13 | 14 | let version = Mdb.version 15 | 16 | let pp_error fmt i = 17 | Format.fprintf fmt "%s@." (Mdb.strerror i) 18 | 19 | module Env = struct 20 | 21 | type t = Mdb.env 22 | 23 | (* exception Assert of (t * string) *) 24 | 25 | module Flags = Mdb.EnvFlags 26 | 27 | let create (type p) (perm : p perm) 28 | ?max_readers ?map_size ?max_maps 29 | ?(flags=Flags.none) ?(mode=0o644) 30 | path = 31 | let flags = 32 | match perm with 33 | | Rw -> flags 34 | | Ro -> Flags.(flags + read_only) 35 | in 36 | let env = Mdb.env_create () in 37 | try 38 | let opt_iter f = function 39 | | None -> () 40 | | Some x -> f x 41 | in 42 | opt_iter (Mdb.env_set_mapsize env) map_size ; 43 | opt_iter (Mdb.env_set_maxdbs env) max_maps ; 44 | opt_iter (Mdb.env_set_maxreaders env) max_readers ; 45 | (* Mdb.env_set_assert env (fun env s -> raise (Assert (env,s))) ; *) 46 | Mdb.env_open env path flags mode ; 47 | env 48 | with Error _ as exn -> Mdb.env_close env; raise exn 49 | 50 | let close = Mdb.env_close 51 | 52 | let copy ?(compact=false) db s = 53 | let flag = if compact then Mdb.CopyFlags.compact else Mdb.CopyFlags.none in 54 | Mdb.env_copy db s flag 55 | 56 | let copyfd ?(compact=false) env (fd : Unix.file_descr) = 57 | let flag = if compact then Mdb.CopyFlags.compact else Mdb.CopyFlags.none in 58 | Mdb.env_copyfd env fd flag 59 | 60 | let set_flags = Mdb.env_set_flags 61 | let flags = Mdb.env_get_flags 62 | 63 | let set_map_size = Mdb.env_set_mapsize 64 | 65 | let path = Mdb.env_get_path 66 | let sync ?(force=false) env = Mdb.env_sync env force 67 | 68 | let fd = Mdb.env_get_fd 69 | 70 | let max_readers = Mdb.env_get_maxreaders 71 | 72 | let max_keysize = Mdb.env_get_maxkeysize 73 | 74 | let reader_list env = 75 | let x = ref [] in 76 | assert (Mdb.reader_list env (fun s -> x := s::!x ; 0) = 0); 77 | !x 78 | 79 | let reader_check = Mdb.reader_check 80 | 81 | let stat = Mdb.env_stat 82 | let info = Mdb.env_info 83 | end 84 | 85 | module Txn = struct 86 | type -'perm t = Mdb.txn constraint 'perm = [< `Read | `Write ] 87 | 88 | exception Abort of Obj.t 89 | 90 | let env = Mdb.txn_env 91 | 92 | let abort txn = raise (Abort (Obj.repr txn)) 93 | let go (type p) (perm : p perm) ?txn:parent env f = 94 | let flags = 95 | match perm with 96 | | Rw -> Env.Flags.none 97 | | Ro -> Env.Flags.read_only 98 | in 99 | let txn = Mdb.txn_begin env parent flags in 100 | match f txn with 101 | | result -> 102 | Mdb.txn_commit txn; 103 | Some result 104 | (* In case txn_commit fails with MDB_MAP_FULL or MDB_BAD_TXN, the txn has 105 | * been aborted by txn_commit. In those cases don't catch the exception. *) 106 | | exception Abort t when t == Obj.repr txn || parent = None -> 107 | Mdb.txn_abort txn; 108 | None 109 | | exception exn -> 110 | (*let bt = Printexc.get_raw_backtrace () in*) 111 | Mdb.txn_abort txn; 112 | raise exn 113 | (*Printexc.raise_with_backtrace exn bt - since OCaml 4.05 *) 114 | 115 | (* Used internally for trivial functions, not exported. *) 116 | let trivial perm ?txn e f = 117 | match txn with 118 | | Some txn -> 119 | if e != env txn 120 | (* Cave: this error is not caught by lmdb *) 121 | then invalid_arg "Lmdb: transaction from wrong environment." 122 | else f txn 123 | | None -> 124 | match go perm e f with 125 | | None -> assert false 126 | | Some x -> x 127 | end 128 | 129 | module Conv = struct 130 | type bigstring = Bigstring.t 131 | 132 | module Flags = Mdb.DbiFlags 133 | 134 | type 'a t = { 135 | flags : Flags.t ; 136 | serialise : (int -> Bigstring.t) -> 'a -> Bigstring.t ; 137 | deserialise : Bigstring.t -> 'a ; 138 | } 139 | 140 | let make ?(flags=Flags.none) ~serialise ~deserialise () = 141 | { flags = flags 142 | ; deserialise = deserialise 143 | ; serialise = serialise } 144 | 145 | let serialise { serialise; _ } = serialise 146 | let deserialise { deserialise; _ } = deserialise 147 | let flags { flags; _ } = flags 148 | 149 | let is_int_size n = n = Mdb.sizeof_int || n = Mdb.sizeof_size_t 150 | 151 | let overflow = Invalid_argument "Lmdb: Integer out of bounds" 152 | 153 | let int32_be = 154 | { flags = 155 | if Sys.big_endian && is_int_size 4 156 | then Flags.(integer_key + integer_dup + dup_fixed) 157 | else Flags.(dup_fixed) 158 | ; serialise = begin fun alloc x -> 159 | let a = alloc 4 in 160 | Bigstring.set_int32_be a 0 x; 161 | a 162 | end 163 | ; deserialise = begin fun a -> 164 | Bigstring.get_int32_be a 0 165 | end 166 | } 167 | 168 | let int32_le = 169 | { flags = 170 | if not Sys.big_endian && is_int_size 4 171 | then Flags.(integer_key + integer_dup + dup_fixed) 172 | else Flags.(reverse_key + reverse_dup + dup_fixed) 173 | ; serialise = begin fun alloc x -> 174 | let a = alloc 4 in 175 | Bigstring.set_int32_le a 0 x; 176 | a 177 | end 178 | ; deserialise = begin fun a -> 179 | Bigstring.get_int32_le a 0 180 | end 181 | } 182 | 183 | let int32_as_int { flags; deserialise; serialise } = 184 | { flags 185 | ; serialise = begin 186 | if Sys.int_size <= 32 187 | then fun alloc i -> 188 | serialise alloc @@ Int32.of_int i 189 | else fun alloc i -> 190 | let ix = Int32.of_int i in 191 | if Int32.to_int ix = i 192 | then serialise alloc ix 193 | else raise overflow 194 | end 195 | ; deserialise = begin 196 | if Sys.int_size >= 32 197 | then fun a -> 198 | deserialise a |> Int32.to_int 199 | else fun a -> 200 | let ix = deserialise a in 201 | let i = Int32.to_int ix in 202 | if Int32.of_int i = ix 203 | then i 204 | else raise overflow 205 | end 206 | } 207 | 208 | let int32_be_as_int = int32_as_int int32_be 209 | let int32_le_as_int = int32_as_int int32_le 210 | 211 | let int64_be = 212 | { flags = 213 | if Sys.big_endian && is_int_size 8 214 | then Flags.(integer_key + integer_dup + dup_fixed) 215 | else Flags.(dup_fixed) 216 | ; serialise = begin fun alloc x -> 217 | let a = alloc 8 in 218 | Bigstring.set_int64_be a 0 x; 219 | a 220 | end 221 | ; deserialise = begin fun a -> 222 | Bigstring.get_int64_be a 0 223 | end 224 | } 225 | 226 | let int64_le = 227 | { flags = 228 | if not Sys.big_endian && is_int_size 8 229 | then Flags.(integer_key + integer_dup + dup_fixed) 230 | else Flags.(reverse_key + reverse_dup + dup_fixed) 231 | ; serialise = begin fun alloc x -> 232 | let a = alloc 8 in 233 | Bigstring.set_int64_le a 0 x; 234 | a 235 | end 236 | ; deserialise = begin fun a -> 237 | Bigstring.get_int64_le a 0 238 | end 239 | } 240 | 241 | let int64_as_int { flags; deserialise; serialise } = 242 | { flags 243 | ; serialise = begin fun alloc i -> 244 | serialise alloc @@ Int64.of_int i 245 | end 246 | ; deserialise = begin 247 | if Sys.int_size >= 64 248 | then fun a -> 249 | deserialise a |> Int64.to_int 250 | else fun a -> 251 | let ix = deserialise a in 252 | let i = Int64.to_int ix in 253 | if Int64.of_int i = ix 254 | then i 255 | else raise overflow 256 | end 257 | } 258 | 259 | let int64_be_as_int = int64_as_int int64_be 260 | let int64_le_as_int = int64_as_int int64_le 261 | 262 | let string = 263 | { flags = Flags.none 264 | ; serialise = begin fun alloc s -> 265 | let len = String.length s in 266 | let a = alloc len in 267 | Bigstring.blit_from_string s ~src_off:0 a ~dst_off:0 ~len; 268 | a 269 | end 270 | ; deserialise = begin fun a -> 271 | Bigstring.substring a ~off:0 ~len:(Bigstring.length a) 272 | end 273 | } 274 | 275 | let bigstring = 276 | { flags = Flags.none 277 | ; serialise = (fun _ b -> b) 278 | ; deserialise = (fun b -> b) 279 | } 280 | end 281 | 282 | module Map = struct 283 | type ('k, 'v, -'dup) t = 284 | { env :Env.t 285 | ; mutable dbi :Mdb.dbi 286 | ; flags :Mdb.DbiFlags.t 287 | ; key : 'k Conv.t 288 | ; value : 'v Conv.t 289 | } 290 | constraint 'dup = [< `Dup | `Uni ] 291 | 292 | let env { env; _ } = env 293 | 294 | type 'a card = 295 | | Nodup : [ `Uni ] card 296 | | Dup : [ `Dup | `Uni ] card 297 | 298 | let create 299 | (type dup key value) 300 | (perm : 'openperm perm) 301 | (dup : (dup as 'dup) card) 302 | ~(key : key Conv.t) 303 | ~(value : value Conv.t) 304 | ?(txn : 'openperm Txn.t option) 305 | ?(name : string option) 306 | (env : Env.t) 307 | :(key, value, 'dup) t 308 | = 309 | let create_of_perm (type p) (perm :p perm) = 310 | match perm with 311 | | Ro -> Conv.Flags.none 312 | | Rw -> Conv.Flags.create 313 | in 314 | let flags = 315 | let open Conv.Flags in 316 | create_of_perm perm + 317 | key.flags * (reverse_key + integer_key) + 318 | match dup with 319 | | Nodup -> Conv.Flags.none 320 | | Dup when name = None -> 321 | invalid_arg "Lmdb.Map.create: The unnamed map does not support duplicates" 322 | | Dup -> 323 | dup_sort + 324 | value.flags * (dup_fixed + integer_dup + reverse_dup) 325 | in 326 | let dbi, flags = 327 | Txn.trivial perm ?txn env @@ fun txn -> 328 | let dbi = Mdb.dbi_open txn name flags in 329 | let flags' = Mdb.dbi_flags txn dbi in 330 | if not Conv.Flags.(eq (unset create flags) flags') 331 | then begin 332 | Mdb.dbi_close env dbi; 333 | Printf.sprintf "Lmdb.Map.create: While opening %s got flags %0#x, but expected %0#x\n" 334 | (match name with None -> "" | Some name -> name) 335 | (Conv.Flags.to_int flags') 336 | (Conv.Flags.to_int flags) 337 | |> invalid_arg 338 | end; 339 | dbi, flags 340 | in 341 | { env; dbi; flags; key; value } 342 | 343 | let create dup ~key ~value ?txn ?name env = 344 | create Rw dup ~key ~value ?txn ?name env 345 | and open_existing dup ~key ~value ?txn ?name env = 346 | create Ro dup ~key ~value ?txn ?name env 347 | 348 | let close ({env; dbi; _} as map) = 349 | map.dbi <- Mdb.invalid_dbi; 350 | Mdb.dbi_close env dbi 351 | 352 | let stat ?txn {env; dbi; _} = 353 | Txn.trivial Ro ?txn env @@ fun txn -> 354 | Mdb.dbi_stat txn dbi 355 | 356 | let _flags ?txn {env; dbi; _} = 357 | Txn.trivial Ro env ?txn @@ fun txn -> 358 | Mdb.dbi_flags txn dbi 359 | 360 | let drop ?txn ?(delete=false) ({dbi ;env ;_ } as map) = 361 | if delete then map.dbi <- Mdb.invalid_dbi; 362 | Txn.trivial Rw ?txn env @@ fun txn -> 363 | Mdb.drop txn dbi delete 364 | 365 | let get map ?txn k = 366 | Txn.trivial Ro ?txn map.env @@ fun txn -> 367 | Mdb.get txn map.dbi (map.key.serialise Bigstring.create k) 368 | |> map.value.deserialise 369 | 370 | module Flags = Mdb.PutFlags 371 | 372 | let put_raw_key map ?txn ?(flags=Flags.none) ka v = 373 | if Conv.Flags.(test dup_sort map.flags) 374 | then begin 375 | let va = map.value.serialise Bigstring.create v in 376 | Txn.trivial Rw ?txn map.env @@ fun txn -> 377 | Mdb.put txn map.dbi ka va flags 378 | end 379 | else begin 380 | Txn.trivial Rw ?txn map.env @@ fun txn -> 381 | let va_opt = ref Mdb.Block_option.none in 382 | let alloc len = 383 | if Mdb.Block_option.is_some !va_opt then 384 | invalid_arg "Lmdb: converting function tried to allocate twice."; 385 | let va = Mdb.put_reserve txn map.dbi ka len flags in 386 | va_opt := Mdb.Block_option.some va; 387 | va 388 | in 389 | let va = map.value.serialise alloc v in 390 | if Mdb.Block_option.is_some !va_opt 391 | then begin 392 | if Mdb.Block_option.get_unsafe !va_opt != va then 393 | invalid_arg "Lmdb: converting function allocated, but returned different buffer." 394 | end 395 | else Mdb.put txn map.dbi ka va flags 396 | end 397 | 398 | let add map ?txn ?(flags=Flags.none) k v = 399 | let flags = 400 | if Conv.Flags.(test dup_sort map.flags) 401 | then flags 402 | else Flags.(flags + no_overwrite) 403 | in 404 | let ka = map.key.serialise Bigstring.create k in 405 | put_raw_key map ?txn ~flags ka v 406 | 407 | let set map ?txn ?flags k v = 408 | let ka = map.key.serialise Bigstring.create k in 409 | if Conv.Flags.(test dup_sort map.flags) 410 | then begin 411 | Txn.trivial Rw ?txn map.env @@ fun txn -> 412 | (try Mdb.del txn map.dbi ka Mdb.Block_option.none with Not_found -> ()); 413 | put_raw_key map ~txn ?flags ka v 414 | end 415 | else 416 | put_raw_key map ?txn ?flags ka v 417 | 418 | let remove map ?txn ?value:v k = 419 | let key = map.key and value = map.value in 420 | let ka = key.serialise Bigstring.create k in 421 | let va = match v with 422 | | None -> Mdb.Block_option.none 423 | | Some v -> 424 | Mdb.Block_option.some @@ value.serialise Bigstring.create v 425 | in 426 | Txn.trivial Rw ?txn map.env @@ fun txn -> 427 | Mdb.del txn map.dbi ka va 428 | 429 | let compare_key map ?txn x y = 430 | let key = map.key in 431 | let xa = key.serialise Bigstring.create x in 432 | let ya = key.serialise Bigstring.create y in 433 | Txn.trivial Ro ?txn map.env @@ fun txn -> 434 | Mdb.cmp txn map.dbi xa ya 435 | 436 | let compare_val map ?txn = 437 | if not Conv.Flags.(test dup_sort map.flags) then 438 | invalid_arg "Lmdb: elements are only comparable in a dup_sort map"; 439 | let value = map.value in 440 | fun x y -> 441 | let xa = value.serialise Bigstring.create x in 442 | let ya = value.serialise Bigstring.create y in 443 | Txn.trivial Ro ?txn map.env @@ fun txn -> 444 | Mdb.dcmp txn map.dbi xa ya 445 | 446 | let compare = compare_key 447 | end 448 | 449 | module Cursor = struct 450 | 451 | module Ops = Mdb.Ops 452 | 453 | module Flags = Mdb.PutFlags 454 | 455 | type ('k, 'v, -'perm, -'dup) t = 456 | { cursor: Mdb.cursor 457 | ; map: ('k, 'v, 'dup) Map.t } 458 | constraint 'dup = [< `Dup | `Uni ] 459 | constraint 'perm = [< `Read | `Write ] 460 | 461 | let go perm ?txn (map :_ Map.t) f = 462 | Txn.trivial perm map.env ?txn @@ fun t -> 463 | let cursor = 464 | { cursor = Mdb.cursor_open t map.dbi 465 | ; map = map } 466 | in 467 | match f cursor with 468 | | result -> 469 | Mdb.cursor_close cursor.cursor; 470 | result 471 | | exception exn -> 472 | (*let bt = Printexc.get_raw_backtrace () in*) 473 | Mdb.cursor_close cursor.cursor; 474 | raise exn 475 | (*Printexc.raise_with_backtrace exn bt - since OCaml 4.05 *) 476 | 477 | (* Used internally for trivial functions, not exported. *) 478 | let trivial perm ?cursor (map :_ Map.t) f = 479 | match (cursor :_ t option) with 480 | | Some cursor -> 481 | if cursor.map != map 482 | then invalid_arg 483 | "Lmdb.Cursor.fold: Got cursor for wrong map"; 484 | f cursor 485 | | None -> 486 | go perm map f 487 | 488 | let seek { cursor ; map } k = 489 | let key = map.key and value = map.value in 490 | let ka = key.serialise Bigstring.create k in 491 | let ka', va = 492 | Mdb.cursor_get cursor 493 | (Mdb.Block_option.some ka) 494 | Mdb.Block_option.none 495 | Ops.set 496 | in 497 | assert (ka' = ka); 498 | k, value.deserialise va 499 | 500 | let get cursor k = snd @@ seek cursor k 501 | 502 | let seek_range { cursor ; map } k = 503 | let key = map.key and value = map.value in 504 | let ka, va = 505 | Mdb.cursor_get cursor 506 | (Mdb.Block_option.some (key.serialise Bigstring.create k)) 507 | Mdb.Block_option.none 508 | Ops.set_range 509 | in 510 | key.deserialise ka, value.deserialise va 511 | 512 | let get_prim op { cursor ; map } = 513 | let key = map.key and value = map.value in 514 | let ka, va = 515 | Mdb.cursor_get cursor 516 | Mdb.Block_option.none Mdb.Block_option.none 517 | op 518 | in 519 | key.deserialise ka, value.deserialise va 520 | 521 | let current c = get_prim Ops.get_current c 522 | let first c = get_prim Ops.first c 523 | let last c = get_prim Ops.last c 524 | let next c = get_prim Ops.next c 525 | let prev c = get_prim Ops.prev c 526 | let next_nodup c = get_prim Ops.next_nodup c 527 | let prev_nodup c = get_prim Ops.prev_nodup c 528 | 529 | let count { cursor; _ } = Mdb.cursor_count cursor 530 | 531 | let seek_dup { cursor ; map } k v = 532 | let key = map.key and value = map.value in 533 | let ka = key.serialise Bigstring.create k in 534 | let va = value.serialise Bigstring.create v in 535 | let ka', va' = 536 | Mdb.cursor_get 537 | cursor 538 | (Mdb.Block_option.some ka) 539 | (Mdb.Block_option.some va) 540 | Ops.get_both 541 | in 542 | assert (ka' = ka); 543 | assert (va' = va) 544 | 545 | let seek_range_dup { cursor ; map } k v = 546 | let key = map.key and value = map.value in 547 | let ka, va = 548 | Mdb.cursor_get cursor 549 | (Mdb.Block_option.some (key.serialise Bigstring.create k)) 550 | (Mdb.Block_option.some (value.serialise Bigstring.create v)) 551 | Ops.get_both_range 552 | in 553 | key.deserialise ka, value.deserialise va 554 | 555 | let get_dup_prim op { cursor ; map } = 556 | let value = map.value in 557 | let _, va = 558 | Mdb.cursor_get cursor 559 | Mdb.Block_option.none Mdb.Block_option.none 560 | op 561 | in 562 | value.deserialise va 563 | 564 | let first_dup c = get_dup_prim Ops.first_dup c 565 | let last_dup c = get_dup_prim Ops.last_dup c 566 | let next_dup c = get_dup_prim Ops.next_dup c 567 | let prev_dup c = get_dup_prim Ops.prev_dup c 568 | 569 | let cursor_none cursor = Mdb.cursor_get cursor.cursor 570 | Mdb.Block_option.none Mdb.Block_option.none 571 | 572 | let get_values_multiple cursor len = 573 | let value = cursor.map.value in 574 | assert Conv.Flags.(test dup_fixed cursor.map.flags); 575 | let _, first = cursor_none cursor Ops.first_dup in 576 | let size = Bigstring.length first in 577 | let values = Array.make len (Obj.magic ()) in 578 | let _, buf = cursor_none cursor Ops.get_multiple in 579 | let rec convert buf off i = 580 | if off+size <= Bigstring.length buf 581 | then begin 582 | values.(i) <- value.deserialise @@ Bigstring.sub buf ~off ~len:size; 583 | convert buf (off+size) (i+1) 584 | end 585 | else begin 586 | assert (off = Bigstring.length buf); 587 | i 588 | end 589 | in 590 | let i = convert buf 0 0 in 591 | let rec loop i = 592 | match 593 | try Some (cursor_none cursor Ops.next_multiple) with Not_found -> None 594 | with 595 | | None -> i 596 | | Some (_, buf) -> 597 | loop (convert buf 0 i); 598 | in 599 | let i = loop i in 600 | assert (i = len); 601 | values 602 | 603 | 604 | let get_values_from_first cursor first = 605 | if not Conv.Flags.(test dup_sort cursor.map.flags) 606 | then [| first |] 607 | else begin 608 | let len = Mdb.cursor_count cursor.cursor in 609 | if len > 1 && Conv.Flags.(test (dup_sort + dup_fixed) cursor.map.flags) 610 | then get_values_multiple cursor len 611 | else begin 612 | let values = Array.make len first in 613 | for i = 1 to len - 1 do 614 | values.(i) <- next_dup cursor 615 | done; 616 | values 617 | end 618 | end 619 | 620 | let get_values_from_last cursor last = 621 | if not Conv.Flags.(test dup_sort cursor.map.flags) 622 | then [| last |] 623 | else begin 624 | let len = Mdb.cursor_count cursor.cursor in 625 | if len > 1 && Conv.Flags.(test (dup_sort + dup_fixed) cursor.map.flags) 626 | then begin 627 | let values = get_values_multiple cursor len in 628 | cursor_none cursor Ops.first_dup |> ignore; 629 | values 630 | end 631 | else begin 632 | let values = Array.make len last in 633 | for i = len - 2 downto 0 do 634 | values.(i) <- prev_dup cursor 635 | done; 636 | values 637 | end 638 | end 639 | 640 | let get_all cursor k = 641 | let first = get cursor k in 642 | get_values_from_first cursor first 643 | 644 | let all_prim_from_first cursor f = 645 | let key, first = f cursor in 646 | key, get_values_from_first cursor first 647 | let all_prim_from_last cursor f = 648 | let key, first = f cursor in 649 | key, get_values_from_last cursor first 650 | 651 | let first_all c = all_prim_from_first c first 652 | let next_all c = all_prim_from_first c next_nodup 653 | let last_all c = all_prim_from_last c last 654 | let prev_all c = all_prim_from_last c prev_nodup 655 | let seek_all c k = all_prim_from_first c (fun c -> seek c k) 656 | let seek_range_all c k = all_prim_from_first c (fun c -> seek_range c k) 657 | let current_all c = 658 | first_dup c |> ignore; 659 | all_prim_from_first c current 660 | 661 | let put_raw_key { cursor ; map } ~flags ka v = 662 | let value = map.value in 663 | if Conv.Flags.(test dup_sort map.flags) 664 | then begin 665 | let va = value.serialise Bigstring.create v in 666 | Mdb.cursor_put cursor ka va flags 667 | end 668 | else begin 669 | let va_opt = ref Mdb.Block_option.none in 670 | let alloc len = 671 | if Mdb.Block_option.is_some !va_opt then 672 | invalid_arg "Lmdb: converting function tried to allocate twice."; 673 | va_opt := 674 | Mdb.Block_option.some @@ 675 | Mdb.cursor_put_reserve cursor ka len flags; 676 | Mdb.Block_option.get_unsafe !va_opt 677 | in 678 | let va = value.serialise alloc v in 679 | if Mdb.Block_option.is_some !va_opt 680 | then begin 681 | if Mdb.Block_option.get_unsafe !va_opt != va then 682 | invalid_arg "Lmdb: converting function allocated, but returned different buffer." 683 | end 684 | else Mdb.cursor_put cursor ka va flags 685 | end 686 | 687 | let set { cursor ; map } ?(flags=Flags.none) k v = 688 | let ka = map.key.serialise Bigstring.create k in 689 | if Conv.Flags.(test dup_sort map.flags) 690 | then begin 691 | match 692 | Mdb.cursor_get cursor 693 | (Mdb.Block_option.some ka) 694 | Mdb.Block_option.none 695 | Ops.set 696 | with 697 | | exception Not_found -> () 698 | | _, _ -> Mdb.cursor_del cursor Flags.no_dup_data 699 | end; 700 | let va = map.value.serialise Bigstring.create v in 701 | Mdb.cursor_put cursor ka va flags 702 | 703 | let add cursor ?(flags=Flags.none) k v = 704 | let flags = 705 | if Conv.Flags.(test dup_sort cursor.map.flags) 706 | then flags 707 | else Flags.(flags + no_overwrite) 708 | in 709 | let ka = cursor.map.key.serialise Bigstring.create k in 710 | put_raw_key cursor ~flags ka v 711 | 712 | let remove ?(all=false) cursor = 713 | Mdb.cursor_del cursor.cursor 714 | (if all then Flags.no_dup_data else Flags.none) 715 | 716 | let replace cursor v = 717 | (* mdb_put mdb_current is supposed to replace the current _value_. 718 | * LMDB API documentation says the current key needs to be passed, too. 719 | * So first get the raw current key to pass it back in. *) 720 | let ka, _ = 721 | Mdb.cursor_get cursor.cursor 722 | Mdb.Block_option.none Mdb.Block_option.none 723 | Ops.get_current 724 | in 725 | put_raw_key cursor ~flags:Flags.current ka v 726 | 727 | let fold_prim init step ?cursor ~f acc map = 728 | let fold cursor = 729 | match init cursor with 730 | | exception Not_found -> acc 731 | | key, value -> 732 | let acc = f acc key value in 733 | let rec loop acc = 734 | match step cursor 735 | with 736 | | exception Not_found -> acc 737 | | key, value -> 738 | let acc = f acc key value in 739 | loop acc 740 | in loop acc 741 | in 742 | trivial Ro map ?cursor fold 743 | 744 | let fold_left ?cursor ~f acc map = 745 | fold_prim first next ?cursor ~f acc map 746 | 747 | let fold_right ?cursor ~f map acc = 748 | let f acc key values = f key values acc in 749 | fold_prim last prev ?cursor ~f acc map 750 | 751 | let iter ?cursor ~f map = 752 | fold_left ?cursor () map ~f:(fun _acc key value -> f key value) 753 | 754 | let iter_rev ?cursor ~f map = 755 | fold_right ?cursor map () ~f:(fun key value _acc -> f key value) 756 | 757 | let fold_prim_all init step get_all ?cursor ~f acc map = 758 | let fold cursor = 759 | match init cursor with 760 | | exception Not_found -> acc 761 | | key, first -> 762 | let values = get_all cursor first in 763 | let acc = f acc key values in 764 | let rec loop acc = 765 | match step cursor with 766 | | exception Not_found -> acc 767 | | key, first -> 768 | let values = get_all cursor first in 769 | let acc = f acc key values in 770 | loop acc 771 | in loop acc 772 | in 773 | trivial Ro ?cursor map fold 774 | 775 | let fold_left_all ?cursor ~f acc map = 776 | fold_prim_all first next_nodup get_values_from_first ?cursor ~f acc map 777 | 778 | let fold_right_all ?cursor ~f map acc = 779 | let f acc key values = f key values acc in 780 | fold_prim_all last prev_nodup get_values_from_last ?cursor ~f acc map 781 | 782 | let iter_all ?cursor ~f map = 783 | fold_left_all ?cursor () map ~f:(fun () key values -> f key values) 784 | 785 | let iter_rev_all ?cursor ~f map = 786 | fold_right_all ?cursor map () ~f:(fun key values () -> f key values) 787 | end 788 | -------------------------------------------------------------------------------- /src/lmdb.mli: -------------------------------------------------------------------------------- 1 | (** High level bindings for LMDB. *) 2 | 3 | (** The {{:http://www.lmdb.tech/doc/}LMDB} database 4 | is a fast in-file key-value store that supports ACID transactions. 5 | 6 | These bindings attempt to expose a typesafe yet low-overhead API. 7 | 8 | First, an environment must be opened using {!Env.create}: 9 | 10 | {[let env = Env.(create Rw ~flags:Flags.no_subdir "mydb") ]} 11 | 12 | Now the data file [mydb] and lock file [mydb-lock] have been created 13 | in the current directory. 14 | 15 | One environment may contain multiple named and one unnamed key-value stores. 16 | They are called {e databases} in the 17 | {{:http://www.lmdb.tech/doc/starting.html}LMDB documentation}, but called 18 | {e maps} in these OCaml bindings. 19 | 20 | A single [('key, 'value, [< `Read | `Write], [< `Dup | `Uni ])] {!type: Map.t} 21 | is a key-value store mapping OCaml values of type ['key] to values of 22 | type ['value]. 23 | Multiple values per key are supported on request. 24 | 25 | Using {!Map}, we can open the unnamed map and add our first value: 26 | {[ 27 | let map = Map.open_existing Nodup ~key:Conv.string ~value:Conv.string env in 28 | Map.add map "Bactrian camel" "Elegant and beautiful animal with two humps." 29 | ]} 30 | 31 | {{!Txn}Transactions} and {{!Cursor}Iterators} are also available. 32 | *) 33 | 34 | 35 | (** {2 Raw bindings} *) 36 | 37 | module Mdb = Lmdb_bindings 38 | 39 | 40 | (** {2 Permissions} *) 41 | 42 | (** This library uses [[< `Read | `Write ]] phantom types to encode the 43 | read/write permissions of transactions and cursors. The following values 44 | are used to request read-only or read-write permissions on environments, 45 | transactions and cursors. 46 | *) 47 | type 'a perm = 48 | | Ro : [ `Read ] perm 49 | | Rw : [ `Read | `Write ] perm 50 | 51 | (** {2 Database} *) 52 | 53 | (** Collection of maps stored in a single memory-mapped file. *) 54 | module Env : sig 55 | type t 56 | 57 | module Flags = Mdb.EnvFlags 58 | 59 | (** [create perm path] creates an environment with {!Ro} or {!Rw} permissions 60 | with {e data} and {e lock} files in the already existing directory [path]. 61 | If no separate directory is desired, {!Flags.no_subdir} can be passed. 62 | 63 | The returned handle is not garbage collected and should be closed 64 | explicitely to free locks and prevent corruption on async environments. 65 | 66 | @param map_size Size of the memory map. Limited by the virtual address space. 67 | @param max_readers Maximum number of threads/reader slots. 68 | @param max_maps Maximum number of named maps. 69 | @param mode The UNIX permissions to set on created files and semaphores. Default is [0o644]. 70 | *) 71 | val create : 72 | _ perm -> ?max_readers:int -> ?map_size:int -> ?max_maps:int -> 73 | ?flags:Flags.t -> ?mode:int -> string -> t 74 | 75 | val sync : ?force:bool -> t -> unit 76 | 77 | val close: t -> unit 78 | 79 | val copy : ?compact:bool -> t -> string -> unit 80 | 81 | val copyfd : ?compact:bool -> t -> Unix.file_descr -> unit 82 | 83 | val set_flags : t -> Flags.t -> bool -> unit 84 | 85 | val flags : t -> Flags.t 86 | 87 | val set_map_size : t -> int -> unit 88 | 89 | val path : t -> string 90 | 91 | val fd : t -> Unix.file_descr 92 | 93 | val stat : t -> Mdb.stat 94 | 95 | val info : t -> Mdb.envinfo 96 | 97 | val max_readers : t -> int 98 | 99 | val max_keysize : t -> int 100 | 101 | val reader_list : t -> string list 102 | 103 | val reader_check : t -> int 104 | 105 | end 106 | 107 | (** Series of operations on an environment performed atomically. *) 108 | module Txn : sig 109 | (** A transaction handle. A transaction may be read-only or read-write. *) 110 | type -'perm t constraint 'perm = [< `Read | `Write ] 111 | 112 | (** [go perm env f] 113 | runs a transaction with [perm] read/write permissions in [env]. 114 | 115 | The function [f txn] will receive the transaction handle. All changes to 116 | the environment [env] done using the transaction handle will be persisted 117 | to the environment only when [f] returns. After [f] returned, the 118 | transaction handle is invalid and should therefore not be leaked outside 119 | [f]. 120 | 121 | @return [None] if the transaction was aborted with [abort], and [Some _] otherwise. 122 | @param txn Create a child transaction to [txn]. 123 | This is not supported on an [env] with {!Env.Flags.write_map}. 124 | 125 | Here is an example incrementing a value atomically: 126 | {[ 127 | go Rw env begin fun txn -> 128 | let v = Map.get ~txn k in 129 | Map.add ~txn k (v+1) ; 130 | v 131 | end 132 | ]} 133 | *) 134 | val go : 135 | 'perm perm -> 136 | ?txn:'perm t -> 137 | Env.t -> 138 | ('perm t -> 'a) -> 'a option 139 | 140 | 141 | (** [abort txn] aborts transaction [txn] and the current [go] function, 142 | which will return [None]. 143 | *) 144 | val abort : _ t -> _ 145 | 146 | val env : 'perm t -> Env.t 147 | (** [env txn] returns the environment of [txn] *) 148 | 149 | end 150 | 151 | (** Converters to and from the internal representation of keys and values. 152 | A converter contains serialising and deserialising functions as well as 153 | the flags applied when the converter is used in a map. 154 | *) 155 | module Conv : sig 156 | (** {2 Types } *) 157 | 158 | type 'a t 159 | 160 | type bigstring = 161 | (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t 162 | (** Bigstrings are used to transfer the raw serialised data into and out of 163 | the database. They may point directly to a memory-mapped region of the 164 | database file. *) 165 | 166 | (** Flags describing the (sorting) properties of keys and values of a map. 167 | 168 | See the LMDB documentation for the meaning of these flags. 169 | 170 | You probably won't need those flags since the converters provided in 171 | {!Conv} will already make appropriate use of these flags. 172 | *) 173 | module Flags = Lmdb_bindings.DbiFlags 174 | 175 | (** {2 Constructor and accessors} *) 176 | 177 | val make : 178 | ?flags:Flags.t -> 179 | serialise:((int -> bigstring) -> 'a -> bigstring) -> 180 | deserialise:(bigstring -> 'a) -> unit -> 181 | 'a t 182 | (** [make ~serialise ~deserialise] 183 | creates a converter from a serialising and a deserialising function 184 | 185 | @param serialise [serialise alloc x] 186 | {e may} call [alloc len] {e once} to allocate a [bigstring] of size [len]. 187 | It then {e must} fill the serialised data of [x] into this [bigstring] 188 | and return {e exactly this} bigstring. If [serialise] didn't call [alloc] it may 189 | return any [bigstring]. 190 | [alloc] may return uninitialised memory. It is therefore recommended 191 | that [serialise] overwrites all allocated memory to avoid leaking possibly 192 | sensitive memory content into the database. 193 | 194 | If [serialise] calls [alloc] the library may utilise the [MDB_RESERVE] 195 | interface when appropriate to avoid calls to [malloc] and [memcpy]. 196 | 197 | @param deserialise 198 | The passed {!bigstring} is only valid as long as the current transaction. 199 | It is therefore strongly recommended not to leak it out of [deserialise]. 200 | 201 | @param flags Flags to be set on a map using this converter. 202 | 203 | Depending on the use of a converter as {e key} or {e value} 204 | {!Map.create} and {!Map.open_existing} will select the correct set of 205 | flags: [_key] flags will be used for keys and [_dup] flags will be 206 | used for values on maps supporting duplicates. 207 | 208 | *) 209 | 210 | val serialise : 'a t -> (int -> bigstring) -> 'a -> bigstring 211 | val deserialise : 'a t -> bigstring -> 'a 212 | val flags : _ t -> Flags.t 213 | 214 | (** {2 Predefined converters } *) 215 | 216 | (** {3 Strings } *) 217 | 218 | val bigstring :bigstring t 219 | (** The [bigstring] converter returns bigstrings as returned by the lmdb 220 | backend. These bigstrings point into the environment memory-map and 221 | are therefore only guaranteed to be valid until the transaction ends. 222 | If you need longer-lived values then use the [string] converter, make a copy 223 | or write a custom converter. 224 | *) 225 | 226 | val string :string t 227 | (** The [string] converter simply copies the raw database content from / to 228 | OCaml strings. *) 229 | 230 | 231 | (** {3 Integers } *) 232 | 233 | (** The integer converters will make use of {! Flags.t} as 234 | appropriate so that integers are sorted in ascending order irrespective 235 | of machine endianness. 236 | *) 237 | 238 | val int32_be :Int32.t t 239 | val int64_be :Int64.t t 240 | val int32_le :Int32.t t 241 | val int64_le :Int64.t t 242 | 243 | (** For convenience, the [_as_int] converters convert the internal integer 244 | representation to and from [int]. 245 | @raise Invalid_argument [Invalid_argument "Lmdb: Integer out of bounds"] 246 | *) 247 | 248 | val int32_be_as_int :int t 249 | val int64_be_as_int :int t 250 | val int32_le_as_int :int t 251 | val int64_le_as_int :int t 252 | end 253 | 254 | (** Key-value maps. *) 255 | module Map : sig 256 | (** A handle for a map from keys of type ['key] to values of type ['value]. 257 | The map may support only a single value per key ([[ `Uni ]]) 258 | or multiple values per key ([[ `Dup | `Uni ]]). *) 259 | type ('key, 'value, -'dup) t 260 | constraint 'perm = [< `Read | `Write ] 261 | constraint 'dup = [< `Dup | `Uni ] 262 | 263 | type 'a card = 264 | | Nodup : [ `Uni ] card 265 | | Dup : [ `Dup | `Uni ] card 266 | 267 | (** [create dup ~key ~value env] 268 | open (and possibly create) a map in the environment [env]. 269 | 270 | [dup] may be {!Dup} or {!Nodup}, specifying whether the map supports 271 | multiple values per key. 272 | 273 | Only a single transaction may call this function at a time. 274 | This transaction needs to finish before any other transaction may call 275 | this function. 276 | 277 | @param name if omitted the unnamed map will be opened. Otherwise make 278 | sure that {! Env.create} was called with a large enough [~max_maps]. 279 | @param key Converter for keys 280 | @param value Converter for values 281 | @raise Invalid_argument if an existing map doesn't support duplicates, 282 | but duplicates where requested. 283 | *) 284 | val create : 285 | ([< `Dup | `Uni ] as 'dup) card -> 286 | key :'key Conv.t -> 287 | value :'value Conv.t -> 288 | ?txn :[> `Read | `Write ] Txn.t -> 289 | ?name :string -> 290 | Env.t -> ('key, 'value, 'dup) t 291 | 292 | (** [open_existing env] is like [create], but only opens already existing maps. 293 | @raise Not_found if the map doesn't exist. 294 | *) 295 | val open_existing : 296 | ([< `Dup | `Uni ] as 'dup) card -> 297 | key :'key Conv.t -> 298 | value :'value Conv.t -> 299 | ?txn :[> `Read ] Txn.t -> 300 | ?name :string -> 301 | Env.t -> ('key, 'value, 'dup) t 302 | 303 | (** [close map] closes and invalidates the [map] handle. 304 | Normalle unnecessary. Use with care. See the lmdb manual. *) 305 | val close : _ t -> unit 306 | 307 | (** [env map] returns the environment of [map]. *) 308 | val env : _ t -> Env.t 309 | 310 | (** [get map key] returns the first value associated to [key]. 311 | @raise Not_found if the key is not in the map. 312 | *) 313 | val get : ('key, 'value, _) t -> ?txn:[> `Read ] Txn.t -> 'key -> 'value 314 | 315 | module Flags = Lmdb_bindings.PutFlags 316 | 317 | (** [add map key value] adds [value] to [key]. 318 | 319 | For a map not supporting duplicates an existing value is overwritten. For 320 | a map supporting duplicates the value is added to the key. This is the 321 | same as [overwrite] for duplicate maps, but 322 | [overwrite ~flags:Flags.no_overwrite] for non-duplicate maps. 323 | 324 | @param flags {!Flags} 325 | @raise Exists on maps not supporting duplicates if the key already exists. 326 | @raise Exists if key is already bound to [value] and {! 327 | Map.Flags.no_dup_data} was passed. 328 | *) 329 | val add : ('key, 'value, _) t -> 330 | ?txn:[> `Write ] Txn.t -> ?flags:Flags.t -> 'key -> 'value -> unit 331 | 332 | (** [set map key value] sets binding of [key] to [value]. 333 | 334 | Values of an already existing key are silently overwritten. 335 | 336 | @param flags {!Flags} 337 | *) 338 | val set : ('key, 'value, _) t -> 339 | ?txn:[> `Write ] Txn.t -> ?flags:Flags.t -> 'key -> 'value -> unit 340 | 341 | (** [remove map key] removes [key] from [map]. 342 | 343 | @param value Only the specified value is removed. 344 | If not provided, all the values of [key] and [key] itself are removed. 345 | 346 | @raise Not_found if the key is not in the map. 347 | *) 348 | val remove : ('key, 'value, _) t -> 349 | ?txn:[> `Write ] Txn.t -> ?value:'value -> 'key -> unit 350 | 351 | 352 | (** {2 Misc} *) 353 | 354 | val stat : ?txn: [> `Read ] Txn.t -> ('key, 'value, _) t -> Mdb.stat 355 | 356 | (** [drop ?delete map] Empties [map]. 357 | @param delete If [true] [map] is also deleted from the environment 358 | and the handle [map] invalidated. *) 359 | val drop : ?txn: [> `Write ] Txn.t -> ?delete:bool -> 360 | ('key, 'value, _) t -> unit 361 | 362 | (** [compare_key map ?txn a b] 363 | Compares [a] and [b] as if they were keys in [map]. *) 364 | val compare_key : ('key, 'value, _) t -> ?txn:[> `Read ] Txn.t -> 'key -> 'key -> int 365 | 366 | (** [compare map ?txn a b] Same as [compare_key]. *) 367 | val compare : ('key, 'value, _) t -> ?txn:[> `Read ] Txn.t -> 'key -> 'key -> int 368 | 369 | (** [compare_val map ?txn a b] 370 | Compares [a] and [b] as if they were values in a [dup_sort] [map]. *) 371 | val compare_val : ('key, 'value, [> `Dup ]) t -> ?txn:[> `Read ] Txn.t -> 'value -> 'value -> int 372 | end 373 | 374 | (** Iterators over maps. *) 375 | module Cursor : sig 376 | (** A cursor allows to iterate manually on the map. 377 | Every cursor implicitely uses a transaction. 378 | *) 379 | 380 | (** A cursor inherits two phantom types: the [[< `Read | `Write ]] permissions 381 | from the transaction and the [[< `Dup | `Uni ]] support from the map. 382 | *) 383 | type ('key, 'value, -'perm, -'dup) t 384 | constraint 'perm = [< `Read | `Write ] 385 | constraint 'dup = [< `Dup | `Uni ] 386 | 387 | (** [go perm map ?txn f] makes a cursor in the transaction [txn] using the 388 | function [f cursor]. 389 | 390 | The function [f] will receive the [cursor]. 391 | A cursor can only be created and used inside a transaction. 392 | The cursor inherits the permissions of the transaction. 393 | The cursor should not be leaked outside of [f]. 394 | 395 | Here is an example that returns the first 5 elements of a [map]: 396 | {[ 397 | go ro map begin fun c -> 398 | let h = first c in 399 | let rec aux i = 400 | if i < 5 then next c :: aux (i+1) 401 | else [] 402 | in 403 | h :: aux 1 404 | end 405 | ]} 406 | 407 | @param txn if omitted a transient transaction will implicitely be 408 | created before calling [f] and be committed after [f] returns. 409 | *) 410 | val go : 'perm perm -> ?txn:'perm Txn.t -> ('key, 'value, 'dup) Map.t -> 411 | (('key, 'value, 'perm, 'dup) t -> 'a) -> 'a 412 | 413 | 414 | (** {2 Modification} *) 415 | 416 | module Flags = Lmdb_bindings.PutFlags 417 | 418 | (** [add cursor key value] adds [value] to [key] and moves the cursor to 419 | its position. 420 | 421 | For a map not supporting duplicates an existing value is overwritten. For 422 | a map supporting duplicates the value is added to the key. This is the 423 | same as [overwrite] for duplicate maps, but 424 | [overwrite ~flags:Flags.no_overwrite] for non-duplicate maps. 425 | 426 | @param flags {!Flags} 427 | @raise Exists on maps not supporting duplicates if the key already exists. 428 | @raise Exists if [key] is already bound to [value] and 429 | {! Cursor.Flags.no_dup_data} was passed. 430 | *) 431 | val add : ('key, 'value, [> `Read | `Write ], _) t -> 432 | ?flags:Flags.t -> 'key -> 'value -> unit 433 | 434 | (** [set cursor key value] sets binding of [key] to [value]. 435 | and moves the cursor to its position. 436 | 437 | Values of an already existing key are silently overwritten. 438 | 439 | @param flags {!Flags} 440 | *) 441 | val set : ('key, 'value, _, _) t -> 442 | ?flags:Flags.t -> 'key -> 'value -> unit 443 | 444 | (** [replace cursor value] replace the current value by [value]. *) 445 | val replace : ('key, 'value, [> `Read | `Write ], _) t -> 'value -> unit 446 | 447 | (** [remove cursor] removes the current binding. 448 | @param all If [true] removes all values associated to the current key. 449 | Default is [false]. 450 | *) 451 | val remove : ?all:bool -> ('key, 'value, [> `Read | `Write ], _) t -> unit 452 | 453 | 454 | (** {2 Reading} *) 455 | 456 | (** [current cursor] returns key and value at the position of the cursor. *) 457 | val current : ('key, 'value, [> `Read ], _) t -> 'key * 'value 458 | 459 | (** [current_all cursor] moves the cursor to the {e last} value of the 460 | {e current} key. Returns key and all values of the current key. 461 | *) 462 | val current_all : ('key, 'value, [> `Read ], [> `Dup ]) t -> 'key * 'value array 463 | 464 | (** [count cursor] returns the number of values bound to the current key. *) 465 | val count : ('key, 'value, [> `Read ], [> `Dup ]) t -> int 466 | 467 | 468 | (** {3 Seeking} *) 469 | 470 | (** [get cursor key] moves the cursor to the {e first} value of [key]. *) 471 | val get : ('key, 'value, [> `Read ], _) t -> 'key -> 'value 472 | 473 | (** [get_all cursor key] moves the cursor to the {e last} value of [key]. 474 | Returns all values of [key]. 475 | *) 476 | val get_all : ('key, 'value, [> `Read ], [> `Dup ]) t -> 'key -> 'value array 477 | 478 | (** [seek cursor key] moves the cursor to the first value of [key]. *) 479 | val seek : ('key, 'value, [> `Read ], _) t -> 'key -> 'key * 'value 480 | 481 | (** [seek_all cursor key] 482 | moves the cursor to the {e last} value of [key]. 483 | Returns all values of [key]. 484 | *) 485 | val seek_all : ('key, 'value, [> `Read ], [> `Dup ]) t -> 'key -> 'key * 'value array 486 | 487 | (** [seek_range cursor key] moves the cursor to the {e first} value of the 488 | first key greater than or equal to [key]. 489 | *) 490 | val seek_range : ('key, 'value, [> `Read ], _) t -> 'key -> 'key * 'value 491 | 492 | (** [seek_range_all cursor key] moves the cursor to the {e last} value of the 493 | first key greater than or equal to [key]. Returns all values of this key. 494 | *) 495 | val seek_range_all : ('key, 'value, [> `Read ], [> `Dup ]) t -> 'key -> 'key * 'value array 496 | 497 | (** [seek_dup cursor key value] moves the cursor to [value] of [key]. *) 498 | val seek_dup : ('key, 'value, [> `Read ], [> `Dup ]) t -> 499 | 'key -> 'value -> unit 500 | 501 | (** [seek_range_dup cursor key value] moves the cursor to the first value greater 502 | than or equal to [value] of the first key greater than or equal to [key]. 503 | *) 504 | val seek_range_dup : ('key, 'value, [> `Read ], [> `Dup ]) t -> 505 | 'key -> 'value -> ('key * 'value) 506 | 507 | 508 | (** {3 Moving} *) 509 | 510 | (** {4 Moving over all key-value pairs } *) 511 | 512 | (** [first cursor] moves the cursor to the {e first} value of the first key. *) 513 | val first : ('key, 'value, [> `Read ], _) t -> 'key * 'value 514 | 515 | (** [last cursor] moves the cursor to the {e last} value of the last key. *) 516 | val last : ('key, 'value, [> `Read ], _) t -> 'key * 'value 517 | 518 | (** [next cursor] moves the cursor to the next key-value pair. 519 | This may be the {e next value} of the {e current key} or the 520 | {e first value} of the {e next key}. 521 | *) 522 | val next : ('key, 'value, [> `Read ], _) t -> 'key * 'value 523 | 524 | (** [prev cursor] moves the cursor to the previous key-value pair. 525 | This may be the {e previous value} of the {e current key} or the 526 | {e last value} of the {e previous key}. 527 | *) 528 | val prev : ('key, 'value, [> `Read ], _) t -> 'key * 'value 529 | 530 | 531 | (** {4 Moving to neighboring keys } *) 532 | 533 | (** [next_nodup cursor] 534 | moves the cursor to the {e first} value of the next key. 535 | *) 536 | val next_nodup : ('key, 'value, [> `Read ], _) t -> 'key * 'value 537 | 538 | (** [prev_nodup cursor] 539 | moves the cursor to the {e last} value of the previous key. 540 | *) 541 | val prev_nodup : ('key, 'value, [> `Read ], _) t -> 'key * 'value 542 | 543 | 544 | (** {4 Moving over duplicates of a single key } *) 545 | 546 | (** [first_dup cursor] moves the cursor to the first {e value} of the current key. *) 547 | val first_dup : ('key, 'value, [> `Read ], [> `Dup ]) t -> 'value 548 | 549 | (** [last_dup cursor] moves the cursor to the last {e value} of the current key. *) 550 | val last_dup : ('key, 'value, [> `Read ], [> `Dup ]) t -> 'value 551 | 552 | (** [next_dup cursor] moves the cursor to the next value of the current key. 553 | @raise Not_found if the cursor is already on the last value of the current key. 554 | *) 555 | val next_dup : ('key, 'value, [> `Read ], [> `Dup ]) t -> 'value 556 | 557 | (** [prev_dup cursor] moves the cursor to the previous value of the current key. 558 | @raise Not_found if the cursor is already on the first value of the current key. 559 | *) 560 | val prev_dup : ('key, 'value, [> `Read ], [> `Dup ]) t -> 'value 561 | 562 | 563 | (** {4 Moving over keys getting all duplicates } *) 564 | 565 | (** [first_all cursor] 566 | moves the cursor to the {e last} value of the first key. 567 | Returns all values of the first key. 568 | *) 569 | val first_all : ('key, 'value, [> `Read ], [> `Dup ]) t -> 'key * 'value array 570 | 571 | (** [last_all cursor] 572 | moves the cursor to the {e first} value of the last key. 573 | Returns all values of the {e last} key. 574 | *) 575 | val last_all : ('key, 'value, [> `Read ], [> `Dup ]) t -> 'key * 'value array 576 | 577 | (** [next_all cursor] 578 | moves the cursor to the {e last} value of the next key. 579 | Returns all values of the next key. 580 | *) 581 | val next_all : ('key, 'value, [> `Read ], [> `Dup ]) t -> 'key * 'value array 582 | 583 | (** [prev_all cursor] 584 | moves the cursor to the {e first} value of the previous key. 585 | Returns all values of the previous key. 586 | *) 587 | val prev_all : ('key, 'value, [> `Read ], [> `Dup ]) t -> 'key * 'value array 588 | 589 | 590 | (** {2 Convenient Iterators} *) 591 | 592 | (** Call [f] once for each key-value pair. 593 | Will call [f] multiple times with the same key for duplicates *) 594 | 595 | val iter : 596 | ?cursor:('key, 'value, [> `Read ], 'dup) t -> 597 | f:('key -> 'value -> unit) -> 598 | ('key, 'value, 'dup) Map.t -> 599 | unit 600 | 601 | val iter_rev : 602 | ?cursor:('key, 'value, [> `Read ] as 'perm, 'dup) t -> 603 | f:('key -> 'value -> unit) -> 604 | ('key, 'value, 'dup) Map.t -> 605 | unit 606 | 607 | val fold_left : 608 | ?cursor:('key, 'value, [> `Read ], 'dup) t -> 609 | f:('a -> 'key -> 'value -> 'a) -> 'a -> 610 | ('key, 'value, 'dup) Map.t -> 611 | 'a 612 | 613 | val fold_right : 614 | ?cursor:('key, 'value, [> `Read ], 'dup) t -> 615 | f:('key -> 'value -> 'a -> 'a) -> 616 | ('key, 'value, 'dup) Map.t -> 617 | 'a -> 'a 618 | 619 | (** Call [f] once for each key passing the key and {e all} associated values. *) 620 | 621 | val iter_all : 622 | ?cursor:('key, 'value, [> `Read ], 'dup) t -> 623 | f:('key -> 'value array -> unit) -> 624 | ('key, 'value, [> `Dup ] as 'dup) Map.t -> 625 | unit 626 | 627 | val iter_rev_all : 628 | ?cursor:('key, 'value, [> `Read ] as 'perm, 'dup) t -> 629 | f:('key -> 'value array -> unit) -> 630 | ('key, 'value, [> `Dup ] as 'dup) Map.t -> 631 | unit 632 | 633 | val fold_left_all : 634 | ?cursor:('key, 'value, [> `Read ], 'dup) t -> 635 | f:('a -> 'key -> 'value array -> 'a) -> 'a -> 636 | ('key, 'value, [> `Dup ] as 'dup) Map.t -> 637 | 'a 638 | 639 | val fold_right_all : 640 | ?cursor:('key, 'value, [> `Read ], 'dup) t -> 641 | f:('key -> 'value array -> 'a -> 'a) -> 642 | ('key, 'value, [> `Dup ] as 'dup) Map.t -> 643 | 'a -> 'a 644 | end 645 | 646 | 647 | (** {2 Error reporting} *) 648 | 649 | exception Exists 650 | (** Raised when adding an already existing key to a [`Uni] map or 651 | adding an an already existing value with {! Map.Flags.no_dup_data} to a 652 | key of a [`Dup] map. 653 | 654 | Also raised when trying to [add ~flags:Flags.append(_dup)] non-sorted data. 655 | *) 656 | 657 | exception Not_found 658 | (** Raised when searching for non-existing key *) 659 | 660 | exception Map_full 661 | (** Raised when memory map is full *) 662 | 663 | exception Error of int 664 | (** Other errors are reported with [Invalid_arg s] or [Error n]. *) 665 | 666 | val pp_error : Format.formatter -> int -> unit 667 | (** [pp_error Format.std_formatter e] prepares a human-readable description 668 | of the given error code [n] raised via [Error n]. 669 | *) 670 | 671 | val version : string * int * int * int 672 | (** [(name, major, minor, patch)] *) 673 | -------------------------------------------------------------------------------- /src/lmdb_bindings.ml: -------------------------------------------------------------------------------- 1 | exception Exists 2 | exception Map_full 3 | exception Error of int 4 | 5 | (* return codes *) 6 | external strerror : int -> string = "mdbs_strerror" 7 | 8 | (* Initialise constants and exceptions *) 9 | external init : unit -> ((string * int * int * int) * int array) 10 | = "mdbs_init" 11 | [@@@ocaml.warning "-8"] 12 | let 13 | ( version 14 | , [| append 15 | ; appenddup 16 | ; cp_compact 17 | ; create 18 | ; current 19 | ; dupfixed 20 | ; dupsort 21 | ; first 22 | ; first_dup 23 | ; fixedmap 24 | ; get_both 25 | ; get_both_range 26 | ; get_current 27 | ; get_multiple 28 | ; integerdup 29 | ; integerkey 30 | ; last 31 | ; last_dup 32 | ; mapasync 33 | ; multiple 34 | ; next 35 | ; next_dup 36 | ; next_multiple 37 | ; next_nodup 38 | ; nodupdata 39 | ; nolock 40 | ; nomeminit 41 | ; nometasync 42 | ; nooverwrite 43 | ; nordahead 44 | ; nosubdir 45 | ; nosync 46 | ; notls 47 | ; prev 48 | ; prev_dup 49 | (* ; prev_multiple - only since lmdb 0.9.19 *) 50 | ; prev_nodup 51 | ; rdonly 52 | ; reserve 53 | ; reversedup 54 | ; reversekey 55 | ; set 56 | ; set_key 57 | ; set_range 58 | ; writemap 59 | ; sizeof_int 60 | ; sizeof_size_t 61 | |] ) 62 | = 63 | Callback.register_exception "LmdbExists" Exists; 64 | Callback.register_exception "LmdbError" (Error 0); 65 | Callback.register_exception "LmdbMapFull" (Map_full); 66 | Printexc.register_printer @@ begin function 67 | | Error i -> Some ("Lmdb.Error(" ^ strerror i ^ ")") 68 | | Exists -> Some "Lmdb.Exists" 69 | | _ -> None 70 | end; 71 | init () 72 | [@@@ocaml.warning "+8"] 73 | 74 | module type Flags = sig 75 | type t 76 | external ( + ) : t -> t -> t = "%orint" 77 | external ( * ) : t -> t -> t = "%andint" 78 | val test : t -> t -> bool 79 | val unset : t -> t -> t 80 | external eq : t -> t -> bool = "%equal" 81 | external of_int : int -> t = "%identity" 82 | external to_int : t -> int = "%identity" 83 | val none : t 84 | end 85 | module Flags :Flags with type t = int = struct 86 | type t = int 87 | external ( + ) : t -> t -> t = "%orint" 88 | external ( * ) : t -> t -> t = "%andint" 89 | let test f m = f * m = f 90 | let unset kill flags = flags * lnot kill 91 | external eq : t -> t -> bool = "%equal" 92 | external of_int : int -> t = "%identity" 93 | external to_int : t -> int = "%identity" 94 | let none :t = 0 95 | end 96 | 97 | (* returned by env_stat and dbi_stat *) 98 | type stat = 99 | { psize : int 100 | ; depth : int 101 | ; branch_pages : int 102 | ; leaf_pages : int 103 | ; overflow_pages : int 104 | ; entries : int 105 | } 106 | 107 | (* returned by env_info *) 108 | type envinfo = 109 | { map_addr : int 110 | ; map_size : int 111 | ; last_pgno : int 112 | ; last_txnid : int 113 | ; max_readers : int 114 | ; num_readers : int 115 | } 116 | 117 | type bigstring = Bigstringaf.t 118 | 119 | (* env *) 120 | type env 121 | module EnvFlags = struct 122 | include Flags 123 | let fixed_map = fixedmap 124 | let no_subdir = nosubdir 125 | let no_sync = nosync 126 | let read_only = rdonly 127 | let no_meta_sync = nometasync 128 | let write_map = writemap 129 | let map_async = mapasync 130 | let no_tls = notls 131 | let no_lock = nolock 132 | let no_read_ahead = nordahead 133 | let no_mem_init = nomeminit 134 | end 135 | module CopyFlags = struct 136 | include Flags 137 | let compact = cp_compact 138 | end 139 | external env_create : unit -> env 140 | = "mdbs_env_create" 141 | external env_open : env -> string -> EnvFlags.t -> int -> unit 142 | = "mdbs_env_open" 143 | external env_close : env -> unit 144 | = "mdbs_env_close" 145 | external env_set_mapsize : env -> int -> unit 146 | = "mdbs_env_set_mapsize" 147 | external env_set_maxdbs : env -> int -> unit 148 | = "mdbs_env_set_maxdbs" 149 | external env_set_maxreaders : env -> int -> unit 150 | = "mdbs_env_set_maxreaders" 151 | external env_copy : env -> string -> CopyFlags.t -> unit 152 | = "mdbs_env_copy2" 153 | external env_copyfd : env -> Unix.file_descr -> CopyFlags.t -> unit 154 | = "mdbs_env_copyfd2" 155 | external env_set_flags : env -> EnvFlags.t -> bool -> unit 156 | = "mdbs_env_set_flags" 157 | external env_get_flags : env -> int 158 | = "mdbs_env_get_flags" 159 | external env_get_path : env -> string 160 | = "mdbs_env_get_path" 161 | external env_get_fd : env -> Unix.file_descr 162 | = "mdbs_env_get_fd" 163 | external env_sync : env -> bool -> unit 164 | = "mdbs_env_sync" 165 | external env_get_maxreaders : env -> int 166 | = "mdbs_env_get_maxreaders" 167 | external env_get_maxkeysize : env -> int 168 | = "mdbs_env_get_maxkeysize" 169 | external reader_list : env -> (string -> int) -> int 170 | = "mdbs_reader_list" 171 | external reader_check : env -> int 172 | = "mdbs_reader_check" 173 | external env_stat : env -> stat 174 | = "mdbs_env_stat" 175 | external env_info : env -> envinfo 176 | = "mdbs_env_info" 177 | 178 | (* txn *) 179 | type txn 180 | external txn_env : txn -> env 181 | = "mdbs_txn_env" 182 | external txn_begin : env -> txn option -> EnvFlags.t -> txn 183 | = "mdbs_txn_begin" 184 | external txn_commit : txn -> unit 185 | = "mdbs_txn_commit" 186 | external txn_abort : txn -> unit 187 | = "mdbs_txn_abort" 188 | 189 | (* dbi *) 190 | type dbi 191 | let invalid_dbi :dbi = Obj.magic ~-1 192 | module DbiFlags = struct 193 | include Flags 194 | let reverse_key = reversekey 195 | let dup_sort = dupsort 196 | let integer_key = integerkey 197 | let dup_fixed = dupfixed 198 | let integer_dup = integerdup 199 | let reverse_dup = reversedup 200 | let create = create 201 | end 202 | module PutFlags = struct 203 | include Flags 204 | let no_overwrite = nooverwrite 205 | let no_dup_data = nodupdata 206 | let current = current 207 | let reserve = reserve 208 | let append = append 209 | let append_dup = appenddup 210 | let multiple = multiple 211 | end 212 | module Block_option = struct 213 | type +'a t 214 | let none :_ t = Obj.magic None 215 | external some_unsafe : 'a -> 'a t = "%identity" 216 | external get_unsafe : 'a t -> 'a = "%identity" 217 | let is_some o = Obj.(is_block (repr o)) 218 | let is_none o = not (is_some o) 219 | let some x = assert (is_some x); some_unsafe x 220 | let get_exn o = 221 | if is_some o 222 | then get_unsafe o 223 | else raise Not_found 224 | end 225 | external dbi_open 226 | : txn -> string option -> Flags.t -> dbi 227 | = "mdbs_dbi_open" 228 | external dbi_close : env -> dbi -> unit 229 | = "mdbs_dbi_close" 230 | external dbi_flags : txn -> dbi -> Flags.t 231 | = "mdbs_dbi_flags" 232 | external dbi_stat : txn -> dbi -> stat 233 | = "mdbs_stat" 234 | external drop : txn -> dbi -> bool -> unit 235 | = "mdbs_drop" 236 | external get 237 | : txn -> dbi -> bigstring -> bigstring 238 | = "mdbs_get" 239 | external put 240 | : txn -> dbi -> bigstring -> bigstring -> 241 | PutFlags.t -> unit 242 | = "mdbs_put" 243 | external put_reserve 244 | : txn -> dbi -> bigstring -> int -> 245 | PutFlags.t -> bigstring 246 | = "mdbs_put" 247 | external del 248 | : txn -> dbi -> 249 | bigstring -> bigstring Block_option.t -> unit 250 | = "mdbs_del" 251 | external cmp 252 | : txn -> dbi -> bigstring -> bigstring -> int 253 | = "mdbs_cmp" 254 | external dcmp 255 | : txn -> dbi -> bigstring -> bigstring -> int 256 | = "mdbs_dcmp" 257 | 258 | (* cursor *) 259 | type cursor 260 | module Ops = struct 261 | type t = int 262 | let first = first 263 | let first_dup = first_dup 264 | let get_both = get_both 265 | let get_both_range = get_both_range 266 | let get_current = get_current 267 | let get_multiple = get_multiple 268 | let last = last 269 | let last_dup = last_dup 270 | let next = next 271 | let next_dup = next_dup 272 | let next_multiple = next_multiple 273 | let next_nodup = next_nodup 274 | let prev = prev 275 | let prev_dup = prev_dup 276 | let prev_nodup = prev_nodup 277 | let set = set 278 | let set_key = set_key 279 | let set_range = set_range 280 | (* let prev_multiple = prev_multiple - only since lmdb 0.9.19 *) 281 | end 282 | external cursor_open : txn -> dbi -> cursor 283 | = "mdbs_cursor_open" 284 | external cursor_close : cursor -> unit 285 | = "mdbs_cursor_close" 286 | external cursor_put 287 | : cursor -> bigstring -> bigstring -> 288 | PutFlags.t -> unit 289 | = "mdbs_cursor_put" 290 | external cursor_put_reserve 291 | : cursor -> bigstring -> int -> 292 | PutFlags.t -> bigstring 293 | = "mdbs_cursor_put" 294 | external cursor_del 295 | : cursor -> PutFlags.t -> unit 296 | = "mdbs_cursor_del" 297 | external cursor_get 298 | : cursor -> 299 | bigstring Block_option.t -> bigstring Block_option.t -> Ops.t -> 300 | bigstring * bigstring 301 | = "mdbs_cursor_get" 302 | external cursor_count : cursor -> int 303 | = "mdbs_cursor_count" 304 | -------------------------------------------------------------------------------- /src/lmdb_bindings.mli: -------------------------------------------------------------------------------- 1 | (** Raw bindings for LMDB. *) 2 | 3 | type bigstring = 4 | (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t 5 | 6 | val version : string * int * int * int 7 | 8 | 9 | (** {2 Exceptions} *) 10 | 11 | exception Exists 12 | exception Map_full 13 | exception Error of int 14 | external strerror : int -> string = "mdbs_strerror" 15 | 16 | 17 | (** {2 Flags} *) 18 | 19 | (** Operations on sets of flags. *) 20 | module type Flags = sig 21 | type t 22 | (** The type of a set of flags *) 23 | 24 | external ( + ) : t -> t -> t = "%orint" 25 | (** [a + b] is the {e union} of flag sets [a] and [b]. 26 | This corresponds to a bitwise {e or} on C bitfields. *) 27 | 28 | external ( * ) : t -> t -> t = "%andint" 29 | (** [a * b] is the intersection of flag sets a and b. 30 | This corresponds to a bitwise {e and} on C bitfields. *) 31 | 32 | val test : t -> t -> bool 33 | (** [test a b] is [true] only if [a] is a subset of [b]. 34 | This corresponds to [a & b == a] for C bitfields. *) 35 | 36 | val unset : t -> t -> t 37 | (** [unset a b] removes flags [a] from flag set [b]. 38 | This corresponds to [a & ~b] for C bitfields. *) 39 | 40 | external eq : t -> t -> bool = "%equal" 41 | (** [eq a b] The equals relation. *) 42 | 43 | external of_int : int -> t = "%identity" 44 | external to_int : t -> int = "%identity" 45 | 46 | val none : t 47 | (** [none] The empty set of flags. *) 48 | end 49 | 50 | module Flags : Flags 51 | 52 | 53 | (** {2 Environment} *) 54 | 55 | type env 56 | module EnvFlags : 57 | sig 58 | include Flags 59 | val fixed_map : t 60 | val no_subdir : t 61 | (** Create the environment not in an existing directory, 62 | but create the data file with exactly the filename given to {!Env.create}. 63 | The lock file will have "-lock" appended. 64 | *) 65 | 66 | val no_sync : t 67 | val read_only : t 68 | val no_meta_sync : t 69 | val write_map : t 70 | val map_async : t 71 | val no_tls : t 72 | val no_lock : t 73 | val no_read_ahead : t 74 | val no_mem_init : t 75 | end 76 | module CopyFlags : 77 | sig 78 | include Flags 79 | val compact : t 80 | end 81 | external env_create : unit -> env = "mdbs_env_create" 82 | external env_open : 83 | env -> string -> EnvFlags.t -> int -> unit 84 | = "mdbs_env_open" 85 | external env_close : env -> unit = "mdbs_env_close" 86 | external env_set_mapsize : env -> int -> unit 87 | = "mdbs_env_set_mapsize" 88 | external env_set_maxdbs : env -> int -> unit 89 | = "mdbs_env_set_maxdbs" 90 | external env_set_maxreaders : env -> int -> unit 91 | = "mdbs_env_set_maxreaders" 92 | external env_copy : env -> string -> CopyFlags.t -> unit 93 | = "mdbs_env_copy2" 94 | external env_copyfd : 95 | env -> Unix.file_descr -> CopyFlags.t -> unit 96 | = "mdbs_env_copyfd2" 97 | external env_set_flags : 98 | env -> EnvFlags.t -> bool -> unit 99 | = "mdbs_env_set_flags" 100 | external env_get_flags : env -> EnvFlags.t 101 | = "mdbs_env_get_flags" 102 | external env_get_path : env -> string 103 | = "mdbs_env_get_path" 104 | external env_get_fd : env -> Unix.file_descr 105 | = "mdbs_env_get_fd" 106 | external env_sync : env -> bool -> unit = "mdbs_env_sync" 107 | external env_get_maxreaders : env -> int 108 | = "mdbs_env_get_maxreaders" 109 | external env_get_maxkeysize : env -> int 110 | = "mdbs_env_get_maxkeysize" 111 | external reader_list : env -> (string -> int) -> int 112 | = "mdbs_reader_list" 113 | external reader_check : env -> int = "mdbs_reader_check" 114 | type stat = { 115 | psize : int; 116 | depth : int; 117 | branch_pages : int; 118 | leaf_pages : int; 119 | overflow_pages : int; 120 | entries : int; 121 | } 122 | external env_stat : env -> stat = "mdbs_env_stat" 123 | type envinfo = 124 | { map_addr : int 125 | (** To recover the actual address this integer needs to be shifted to the 126 | left by one bit. A 31 bit integer may overflow. *) 127 | ; map_size : int 128 | ; last_pgno : int 129 | ; last_txnid : int 130 | ; max_readers : int 131 | ; num_readers : int 132 | } 133 | external env_info : env -> envinfo = "mdbs_env_info" 134 | 135 | 136 | (** {2 Transaction} *) 137 | 138 | type txn 139 | external txn_env : txn -> env = "mdbs_txn_env" 140 | external txn_begin : 141 | env -> txn option -> EnvFlags.t -> txn 142 | = "mdbs_txn_begin" 143 | external txn_commit : txn -> unit = "mdbs_txn_commit" 144 | external txn_abort : txn -> unit = "mdbs_txn_abort" 145 | 146 | 147 | (** {2 Dbi} *) 148 | 149 | type dbi 150 | val invalid_dbi : dbi 151 | module DbiFlags : 152 | sig 153 | include Flags 154 | val reverse_key : t 155 | val dup_sort : t 156 | val integer_key : t 157 | val dup_fixed : t 158 | val integer_dup : t 159 | val reverse_dup : t 160 | val create : t 161 | end 162 | module PutFlags : 163 | sig 164 | include Flags 165 | val no_overwrite : t 166 | (** Raise {!exception: Exists} if the key already exists no matter whether the map 167 | supports duplicates. 168 | *) 169 | 170 | val no_dup_data : t 171 | (** Only for maps supporting duplicates: Don't add the value to an already 172 | existing key if this value is already part of this key. 173 | *) 174 | 175 | val append : t 176 | (** Add a key that is greater than any existing key. 177 | Used to efficiently add sorted data. 178 | *) 179 | 180 | val append_dup : t 181 | (** Add value to key that is greater than any existing value of this key. 182 | Used to efficiently add sorted values to a key. 183 | *) 184 | 185 | val current : t 186 | val reserve : t 187 | val multiple : t 188 | end 189 | module Block_option : 190 | sig 191 | type +'a t 192 | val none : 'a t 193 | external some_unsafe : 'a -> 'a t = "%identity" 194 | external get_unsafe : 'a t -> 'a = "%identity" 195 | val is_some : 'a -> bool 196 | val is_none : 'a -> bool 197 | val some : 'a -> 'a t 198 | val get_exn : 'a t -> 'a 199 | end 200 | external dbi_open : 201 | txn -> string option -> DbiFlags.t -> dbi 202 | = "mdbs_dbi_open" 203 | external dbi_close : env -> dbi -> unit 204 | = "mdbs_dbi_close" 205 | external dbi_flags : txn -> dbi -> DbiFlags.t 206 | = "mdbs_dbi_flags" 207 | external dbi_stat : txn -> dbi -> stat 208 | = "mdbs_stat" 209 | external drop : txn -> dbi -> bool -> unit 210 | = "mdbs_drop" 211 | external get : 212 | txn -> dbi -> bigstring -> bigstring 213 | = "mdbs_get" 214 | external put : 215 | txn -> 216 | dbi -> bigstring -> bigstring -> PutFlags.t -> unit = "mdbs_put" 217 | external put_reserve : 218 | txn -> 219 | dbi -> bigstring -> int -> PutFlags.t -> bigstring = "mdbs_put" 220 | external del : 221 | txn -> 222 | dbi -> bigstring -> bigstring Block_option.t -> unit = "mdbs_del" 223 | external cmp : 224 | txn -> dbi -> bigstring -> bigstring -> int 225 | = "mdbs_cmp" 226 | external dcmp : 227 | txn -> dbi -> bigstring -> bigstring -> int 228 | = "mdbs_dcmp" 229 | 230 | 231 | (** {2 Cursor} *) 232 | 233 | type cursor 234 | module Ops : 235 | sig 236 | type t 237 | val first : t 238 | val first_dup : t 239 | val get_both : t 240 | val get_both_range : t 241 | val get_current : t 242 | val get_multiple : t 243 | val last : t 244 | val last_dup : t 245 | val next : t 246 | val next_dup : t 247 | val next_multiple : t 248 | val next_nodup : t 249 | val prev : t 250 | val prev_dup : t 251 | (* let prev_multiple = prev_multiple - only since lmdb 0.9.19 *) 252 | val prev_nodup : t 253 | val set : t 254 | val set_key : t 255 | val set_range : t 256 | end 257 | external cursor_open : txn -> dbi -> cursor 258 | = "mdbs_cursor_open" 259 | external cursor_close : cursor -> unit 260 | = "mdbs_cursor_close" 261 | external cursor_put : 262 | cursor -> 263 | bigstring -> bigstring -> PutFlags.t -> unit = "mdbs_cursor_put" 264 | external cursor_put_reserve : 265 | cursor -> 266 | bigstring -> int -> PutFlags.t -> bigstring = "mdbs_cursor_put" 267 | external cursor_del : cursor -> PutFlags.t -> unit 268 | = "mdbs_cursor_del" 269 | external cursor_get : 270 | cursor -> 271 | bigstring Block_option.t -> 272 | bigstring Block_option.t -> Ops.t -> bigstring * bigstring 273 | = "mdbs_cursor_get" 274 | external cursor_count : cursor -> int 275 | = "mdbs_cursor_count" 276 | 277 | 278 | (** {2 Internal} *) 279 | 280 | val sizeof_int : int 281 | val sizeof_size_t : int 282 | -------------------------------------------------------------------------------- /src/lmdb_stubs.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2019, Christopher Zimmermann 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 11 | * SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION 13 | * OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN 14 | * CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | */ 16 | 17 | 18 | #include 19 | #include 20 | #include 21 | 22 | #define CAML_NAME_SPACE 23 | #include 24 | #include 25 | #include 26 | #include 27 | #include 28 | #include 29 | #include 30 | #include 31 | #include 32 | 33 | 34 | int constants[] = { 35 | MDB_APPEND, 36 | MDB_APPENDDUP, 37 | MDB_CP_COMPACT, 38 | MDB_CREATE, 39 | MDB_CURRENT, 40 | MDB_DUPFIXED, 41 | MDB_DUPSORT, 42 | MDB_FIRST, 43 | MDB_FIRST_DUP, 44 | MDB_FIXEDMAP, 45 | MDB_GET_BOTH, 46 | MDB_GET_BOTH_RANGE, 47 | MDB_GET_CURRENT, 48 | MDB_GET_MULTIPLE, 49 | MDB_INTEGERDUP, 50 | MDB_INTEGERKEY, 51 | MDB_LAST, 52 | MDB_LAST_DUP, 53 | MDB_MAPASYNC, 54 | MDB_MULTIPLE, 55 | MDB_NEXT, 56 | MDB_NEXT_DUP, 57 | MDB_NEXT_MULTIPLE, 58 | MDB_NEXT_NODUP, 59 | MDB_NODUPDATA, 60 | MDB_NOLOCK, 61 | MDB_NOMEMINIT, 62 | MDB_NOMETASYNC, 63 | MDB_NOOVERWRITE, 64 | MDB_NORDAHEAD, 65 | MDB_NOSUBDIR, 66 | MDB_NOSYNC, 67 | MDB_NOTLS, 68 | MDB_PREV, 69 | MDB_PREV_DUP, 70 | /* MDB_PREV_MULTIPLE - only since 0.9.19 */ 71 | MDB_PREV_NODUP, 72 | MDB_RDONLY, 73 | MDB_RESERVE, 74 | MDB_REVERSEDUP, 75 | MDB_REVERSEKEY, 76 | MDB_SET, 77 | MDB_SET_KEY, 78 | MDB_SET_RANGE, 79 | MDB_WRITEMAP, 80 | sizeof(int), 81 | sizeof(size_t), 82 | }; 83 | 84 | const value *exn_exists; 85 | const value *exn_map_full; 86 | const value *exn_error; 87 | 88 | 89 | void mdbs_assert_func(MDB_env *env, const char *msg) { 90 | const char *path; 91 | mdb_env_get_path(env, &path); 92 | char text[39 + strlen(path) + strlen(msg)]; 93 | 94 | strcpy(text, "Lmdb backend assertion failure in "); 95 | strcat(text, path); 96 | strcat(text, " at "); 97 | strcat(text, msg); 98 | 99 | caml_acquire_runtime_system(); 100 | caml_failwith(text); 101 | } 102 | 103 | CAMLprim value mdbs_init(value unit) 104 | { 105 | CAMLparam0(); 106 | CAMLlocal4(version, string, array, pair); 107 | int major, minor, patch; 108 | unsigned i; 109 | 110 | exn_exists = caml_named_value("LmdbExists"); 111 | exn_map_full = caml_named_value("LmdbMapFull"); 112 | exn_error = caml_named_value("LmdbError"); 113 | 114 | string = caml_copy_string(mdb_version(&major, &minor, &patch)); 115 | 116 | version = caml_alloc_small(4, 0); 117 | Field(version, 0) = string; 118 | Field(version, 1) = Val_int(major); 119 | Field(version, 2) = Val_int(minor); 120 | Field(version, 3) = Val_int(patch); 121 | 122 | CAMLassert(sizeof(constants) / sizeof(value) <= Max_young_wosize); 123 | array = caml_alloc_small(sizeof(constants) / sizeof(constants[0]), 0); 124 | for (i = 0; i < Wosize_val(array); i++) 125 | Field(array, i) = Val_int(constants[i]); 126 | 127 | pair = caml_alloc_small(2, 0); 128 | Field(pair, 0) = version; 129 | Field(pair, 1) = array; 130 | 131 | CAMLreturn(pair); 132 | } 133 | 134 | CAMLprim value mdbs_strerror(value errn) 135 | { 136 | return caml_copy_string(mdb_strerror(Int_val(errn))); 137 | } 138 | 139 | void mdbs_err(int errn) 140 | { 141 | switch (errn) 142 | { 143 | case MDB_SUCCESS: 144 | return; 145 | case MDB_NOTFOUND: 146 | caml_raise_not_found(); 147 | case MDB_KEYEXIST: 148 | caml_raise_constant(*exn_exists); 149 | case MDB_MAP_FULL: 150 | caml_raise_constant(*exn_map_full); 151 | case EINVAL: 152 | caml_invalid_argument("Lmdb"); 153 | default: 154 | caml_raise_with_arg(*exn_error, Val_int(errn)); 155 | } 156 | } 157 | 158 | #define mdbs_err_rel(ferr) \ 159 | do { \ 160 | int errn; \ 161 | caml_release_runtime_system(); \ 162 | errn = (ferr); \ 163 | caml_acquire_runtime_system(); \ 164 | if (errn) mdbs_err(errn); \ 165 | } while(0) 166 | 167 | static inline value hide(void *p) 168 | { 169 | CAMLassert(((intnat)p & 1) == 0); 170 | return ((intnat)p | 1); 171 | } 172 | static inline void *unhide(value v) 173 | { 174 | CAMLassert(((intnat)v & 1) == 1); 175 | return ((void *)((v) & ~1)); 176 | } 177 | 178 | CAMLprim value mdbs_env_create(value unit) 179 | { 180 | MDB_env *env; 181 | mdbs_err_rel(mdb_env_create(&env)); 182 | mdb_env_set_assert(env, mdbs_assert_func); 183 | 184 | return hide(env); 185 | } 186 | 187 | CAMLprim value mdbs_env_open(value env, value path, value flags, value mode) 188 | { 189 | char cpath[caml_string_length(path) + 1]; 190 | memcpy(cpath, String_val(path), sizeof(cpath)); 191 | 192 | mdbs_err_rel(mdb_env_open( 193 | unhide(env), 194 | cpath, 195 | Unsigned_int_val(flags), 196 | Int_val(mode))); 197 | 198 | return Val_unit; 199 | } 200 | 201 | CAMLprim value mdbs_env_close(value env) 202 | { 203 | caml_release_runtime_system(); 204 | mdb_env_close(unhide(env)); 205 | caml_acquire_runtime_system(); 206 | 207 | return Val_unit; 208 | } 209 | 210 | #define set(name, type) \ 211 | CAMLprim value mdbs_ ## name (value ctx, value x) { \ 212 | mdbs_err_rel(mdb_ ## name (unhide(ctx), (type)Long_val(x))); \ 213 | return Val_unit; } 214 | 215 | #define get(name, type) \ 216 | CAMLprim value mdbs_ ## name (value ctx) { \ 217 | type x; \ 218 | mdbs_err_rel(mdb_ ## name (unhide(ctx), &x)); \ 219 | return Val_int(x); } 220 | 221 | set(env_set_mapsize, uintnat) 222 | set(env_set_maxdbs, unsigned) 223 | set(env_set_maxreaders, unsigned) 224 | get(env_get_maxreaders, unsigned) 225 | get(env_get_flags, unsigned) 226 | get(reader_check, int) 227 | get(cursor_count, size_t) 228 | 229 | 230 | CAMLprim value mdbs_env_get_maxkeysize(value env) 231 | { 232 | caml_release_runtime_system(); 233 | int ret = Val_int(mdb_env_get_maxkeysize(unhide(env))); 234 | caml_acquire_runtime_system(); 235 | return ret; 236 | } 237 | 238 | CAMLprim value mdbs_env_set_flags(value env, value flags, value onoff) 239 | { 240 | mdbs_err_rel(mdb_env_set_flags( 241 | unhide(env), 242 | Unsigned_long_val(flags), 243 | Unsigned_long_val(onoff))); 244 | 245 | return Val_unit; 246 | } 247 | 248 | CAMLprim value mdbs_dbi_flags(value txn, value dbi) { 249 | unsigned flags; 250 | mdbs_err_rel(mdb_dbi_flags( 251 | unhide(txn), 252 | Unsigned_int_val(dbi), 253 | &flags)); 254 | return Val_int(flags); 255 | } 256 | 257 | int mdbs_msg_func(const char *msg, void *callback) 258 | { 259 | int ret; 260 | caml_acquire_runtime_system(); 261 | ret = Int_val(caml_callback( 262 | *(value *)callback, 263 | caml_copy_string(msg))); 264 | caml_release_runtime_system(); 265 | return ret; 266 | } 267 | 268 | CAMLprim value mdbs_reader_list(value env, value callback) 269 | { 270 | CAMLparam1(callback); 271 | 272 | caml_release_runtime_system(); 273 | int ret = 274 | mdb_reader_list( 275 | unhide(env), 276 | &mdbs_msg_func, 277 | &callback); 278 | caml_acquire_runtime_system(); 279 | 280 | if (ret < 0) 281 | mdbs_err(ret); 282 | 283 | CAMLreturn(Val_int(ret)); 284 | } 285 | 286 | value make_stat(MDB_stat *cstat) 287 | { 288 | value stat; 289 | 290 | stat = caml_alloc_small(6,0); 291 | Field(stat, 0) = Val_int (cstat->ms_psize); 292 | Field(stat, 1) = Val_int (cstat->ms_depth); 293 | Field(stat, 2) = Val_long(cstat->ms_branch_pages); 294 | Field(stat, 3) = Val_long(cstat->ms_leaf_pages); 295 | Field(stat, 4) = Val_long(cstat->ms_overflow_pages); 296 | Field(stat, 5) = Val_long(cstat->ms_entries); 297 | 298 | return stat; 299 | } 300 | 301 | CAMLprim value mdbs_env_stat(value env) 302 | { 303 | MDB_stat cstat; 304 | 305 | mdbs_err_rel(mdb_env_stat( 306 | unhide(env), 307 | &cstat)); 308 | 309 | return make_stat(&cstat); 310 | } 311 | 312 | CAMLprim value mdbs_stat(value txn, value dbi) 313 | { 314 | MDB_stat cstat; 315 | 316 | mdbs_err_rel(mdb_stat( 317 | unhide(txn), 318 | Unsigned_int_val(dbi), 319 | &cstat)); 320 | 321 | return make_stat(&cstat); 322 | } 323 | 324 | CAMLprim value mdbs_env_info(value env) 325 | { 326 | MDB_envinfo cinfo; 327 | value info; 328 | 329 | mdbs_err_rel(mdb_env_info( 330 | unhide(env), 331 | &cinfo)); 332 | 333 | info = caml_alloc_small(6,0); 334 | Field(info, 0) = hide(cinfo.me_mapaddr); 335 | Field(info, 1) = Val_long(cinfo.me_mapsize); 336 | Field(info, 2) = Val_long(cinfo.me_last_pgno); 337 | Field(info, 3) = Val_long(cinfo.me_last_txnid); 338 | Field(info, 4) = Val_int (cinfo.me_maxreaders); 339 | Field(info, 5) = Val_int (cinfo.me_numreaders); 340 | 341 | return info; 342 | } 343 | 344 | CAMLprim value mdbs_env_copy2(value env, value path, value flags) 345 | { 346 | char cpath[caml_string_length(path) + 1]; 347 | memcpy(cpath, String_val(path), sizeof(cpath)); 348 | 349 | mdbs_err_rel(mdb_env_copy2( 350 | unhide(env), 351 | cpath, 352 | Unsigned_int_val(flags))); 353 | 354 | return Val_unit; 355 | } 356 | 357 | CAMLprim value mdbs_env_copyfd2(value env, value fd, value flags) 358 | { 359 | #ifdef Handle_val 360 | CAMLparam1(fd); 361 | HANDLE cfd = Handle_val(fd); 362 | CAMLassert(Is_block(fd)); 363 | #else 364 | CAMLparam0(); 365 | int cfd = Int_val(fd); 366 | CAMLassert(Is_long(fd)); 367 | #endif 368 | 369 | mdbs_err_rel(mdb_env_copyfd2( 370 | unhide(env), 371 | cfd, 372 | Unsigned_int_val(flags))); 373 | 374 | CAMLreturn(Val_unit); 375 | } 376 | 377 | CAMLprim value mdbs_env_get_path(value env) 378 | { 379 | const char *path; 380 | 381 | mdbs_err_rel(mdb_env_get_path(unhide(env), &path)); 382 | 383 | return caml_copy_string(path); 384 | } 385 | 386 | CAMLprim value mdbs_env_get_fd(value env) 387 | { 388 | mdb_filehandle_t fd; 389 | 390 | mdbs_err_rel(mdb_env_get_fd( 391 | unhide(env), 392 | &fd)); 393 | 394 | #ifdef Handle_val 395 | return win_alloc_handle(fd); 396 | #else 397 | return Val_int(fd); 398 | #endif 399 | } 400 | 401 | CAMLprim value mdbs_env_sync(value env, value force) 402 | { 403 | mdbs_err_rel(mdb_env_sync(unhide(env), Bool_val(force))); 404 | 405 | return Val_unit; 406 | } 407 | 408 | CAMLprim value mdbs_txn_env (value txn) 409 | { 410 | MDB_env *env; 411 | caml_release_runtime_system(); 412 | env = mdb_txn_env(unhide(txn)); 413 | caml_acquire_runtime_system(); 414 | 415 | if (env == NULL) 416 | caml_invalid_argument("Lmdb.Txn.env: invalid transaction handle."); 417 | 418 | return hide(env); 419 | } 420 | 421 | CAMLprim value mdbs_txn_begin (value env, value parent, value flags) 422 | { 423 | MDB_txn *cparent, *txn; 424 | 425 | if (Is_block(parent)) { 426 | /* Some */ 427 | CAMLassert(Tag_val(parent) == 0); 428 | cparent = unhide(Field(parent,0)); 429 | } 430 | else { 431 | /* None */ 432 | CAMLassert(Int_val(parent) == 0); 433 | cparent = NULL; 434 | } 435 | 436 | /* mdb_txn_begin locks a mutex. Therefore it has to release the runtime. 437 | * Otherwise a deadlock involving the OCaml global runtime lock and the 438 | * lmdb writer lock could occur. */ 439 | mdbs_err_rel(mdb_txn_begin( 440 | unhide(env), 441 | cparent, 442 | Unsigned_int_val(flags), 443 | &txn)); 444 | 445 | return hide(txn); 446 | } 447 | 448 | CAMLprim value mdbs_cursor_open (value txn, value dbi) 449 | { 450 | MDB_cursor *cursor; 451 | 452 | mdbs_err_rel(mdb_cursor_open( 453 | unhide(txn), 454 | Unsigned_int_val(dbi), 455 | &cursor)); 456 | 457 | return hide(cursor); 458 | } 459 | 460 | CAMLprim value mdbs_txn_commit(value txn) 461 | { 462 | mdbs_err_rel(mdb_txn_commit(unhide(txn))); 463 | return Val_unit; 464 | } 465 | 466 | CAMLprim value mdbs_cursor_close(value cursor) 467 | { 468 | caml_release_runtime_system(); 469 | mdb_cursor_close(unhide(cursor)); 470 | caml_acquire_runtime_system(); 471 | return Val_unit; 472 | } 473 | 474 | CAMLprim value mdbs_txn_abort(value txn) 475 | { 476 | caml_release_runtime_system(); 477 | mdb_txn_abort(unhide(txn)); 478 | caml_acquire_runtime_system(); 479 | return Val_unit; 480 | } 481 | 482 | CAMLprim value mdbs_dbi_open(value txn, value name, value flags) 483 | { 484 | MDB_dbi dbi; 485 | 486 | char cname[Is_block(name) ? caml_string_length(Field(name, 0)) + 1 : 0]; 487 | 488 | if (Is_block(name)) { 489 | CAMLassert(Tag_val(Field(name,0)) == String_tag); 490 | memcpy(cname, String_val(Field(name,0)), sizeof(cname)); 491 | } 492 | else 493 | CAMLassert(Int_val(name) == 0); 494 | 495 | mdbs_err_rel(mdb_dbi_open( 496 | unhide(txn), 497 | Is_block(name) ? cname : NULL, 498 | Unsigned_int_val(flags), 499 | &dbi)); 500 | 501 | return Val_int(dbi); 502 | } 503 | 504 | CAMLprim value mdbs_dbi_close(value env, value dbi) 505 | { 506 | caml_release_runtime_system(); 507 | mdb_dbi_close(unhide(env), Unsigned_int_val(dbi)); 508 | caml_acquire_runtime_system(); 509 | return Val_unit; 510 | } 511 | 512 | 513 | CAMLprim value mdbs_drop(value txn, value dbi, value del) 514 | { 515 | mdbs_err_rel(mdb_drop( 516 | unhide(txn), 517 | Unsigned_int_val(dbi), 518 | Bool_val(del))); 519 | return Val_unit; 520 | } 521 | 522 | static inline void mvp_of_ba(MDB_val *mvp, value ba) 523 | { 524 | struct caml_ba_array *cba = Caml_ba_array_val(ba); 525 | CAMLassert(cba->num_dims == 1); 526 | mvp->mv_size = cba->dim[0]; 527 | mvp->mv_data = cba->data; 528 | } 529 | 530 | static inline void mvp_of_ba_opt(MDB_val *mvp, value opt) 531 | { 532 | if (Is_block(opt)) { 533 | CAMLassert(Tag_val(opt) == Custom_tag); 534 | mvp_of_ba(mvp, opt); 535 | } 536 | else { 537 | mvp->mv_size = Unsigned_long_val(opt); 538 | mvp->mv_data = NULL; 539 | } 540 | } 541 | 542 | static inline value ba_of_mvp(MDB_val *mvp) 543 | { 544 | return 545 | caml_ba_alloc( 546 | #if 0 547 | CAML_BA_MAPPED_FILE | 548 | #endif 549 | CAML_BA_CHAR | CAML_BA_C_LAYOUT | CAML_BA_EXTERNAL, 550 | 1, mvp->mv_data, (intnat *)&mvp->mv_size); 551 | } 552 | 553 | CAMLprim value mdbs_get(value txn, value dbi, value key) 554 | { 555 | CAMLparam1(key); 556 | MDB_val ckey, cval; 557 | 558 | mvp_of_ba(&ckey, key); 559 | 560 | mdbs_err_rel(mdb_get( 561 | unhide(txn), 562 | Unsigned_int_val(dbi), 563 | &ckey, 564 | &cval)); 565 | 566 | CAMLreturn(ba_of_mvp(&cval)); 567 | } 568 | 569 | CAMLprim value mdbs_cursor_get(value cursor, value keyopt, value valopt, value op) 570 | { 571 | CAMLparam2(keyopt, valopt); 572 | CAMLlocal1(ret); 573 | MDB_val ckey, cval; 574 | void *dkey, *dval; 575 | 576 | mvp_of_ba_opt(&ckey, keyopt); 577 | mvp_of_ba_opt(&cval, valopt); 578 | dkey = ckey.mv_data; 579 | dval = cval.mv_data; 580 | 581 | mdbs_err_rel(mdb_cursor_get( 582 | unhide(cursor), 583 | &ckey, 584 | &cval, 585 | Unsigned_int_val(op))); 586 | 587 | ret = caml_alloc_small(2,0); 588 | Field(ret, 0) = Val_unit; 589 | Field(ret, 1) = Val_unit; 590 | if (ckey.mv_data == dkey && Is_block(keyopt)) 591 | Field(ret, 0) = keyopt; 592 | else 593 | Field(ret, 0) = ba_of_mvp(&ckey); 594 | if (cval.mv_data == dval && Is_block(valopt)) 595 | Field(ret, 1) = valopt; 596 | else 597 | Field(ret, 1) = ba_of_mvp(&cval); 598 | 599 | CAMLreturn(ret); 600 | } 601 | 602 | CAMLprim value mdbs_del(value txn, value dbi, value key, value valopt) 603 | { 604 | CAMLparam2(key, valopt); 605 | MDB_val ckey, cval; 606 | 607 | mvp_of_ba(&ckey, key); 608 | 609 | if (Is_block(valopt)) { 610 | CAMLassert(Tag_val(valopt) == Custom_tag); 611 | mvp_of_ba(&cval, valopt); 612 | } 613 | 614 | mdbs_err_rel(mdb_del( 615 | unhide(txn), 616 | Unsigned_int_val(dbi), 617 | &ckey, 618 | Is_block(valopt) ? &cval : NULL)); 619 | 620 | CAMLreturn(Val_unit); 621 | } 622 | 623 | CAMLprim value mdbs_cursor_del(value cursor, value flags) 624 | { 625 | mdbs_err_rel(mdb_cursor_del(unhide(cursor), Unsigned_int_val(flags))); 626 | return Val_unit; 627 | } 628 | 629 | CAMLprim value mdbs_put(value txn, value dbi, value key, value valopt, value flags) 630 | { 631 | CAMLparam2(key, valopt); 632 | MDB_val ckey, cval; 633 | 634 | mvp_of_ba(&ckey, key); 635 | mvp_of_ba_opt(&cval, valopt); 636 | 637 | mdbs_err_rel(mdb_put( 638 | unhide(txn), 639 | Unsigned_int_val(dbi), 640 | &ckey, 641 | &cval, 642 | Unsigned_int_val(flags) | (Is_block(valopt) ? 0 : MDB_RESERVE))); 643 | 644 | if (Is_block(valopt)) 645 | CAMLreturn(Val_unit); 646 | else 647 | CAMLreturn(ba_of_mvp(&cval)); 648 | } 649 | 650 | CAMLprim value mdbs_cursor_put(value cursor, value key, value valopt, value flags) 651 | { 652 | CAMLparam2(key, valopt); 653 | MDB_val ckey, cval; 654 | 655 | mvp_of_ba(&ckey, key); 656 | mvp_of_ba_opt(&cval, valopt); 657 | 658 | mdbs_err_rel(mdb_cursor_put( 659 | unhide(cursor), 660 | &ckey, 661 | &cval, 662 | Unsigned_int_val(flags) | (Is_block(valopt) ? 0 : MDB_RESERVE))); 663 | 664 | if (Is_block(valopt)) 665 | CAMLreturn(Val_unit); 666 | else 667 | CAMLreturn(ba_of_mvp(&cval)); 668 | } 669 | 670 | CAMLprim value mdbs_cmp(value txn, value dbi, value key, value val) 671 | { 672 | MDB_val ckey, cval; 673 | int ret; 674 | 675 | mvp_of_ba(&ckey, key); 676 | mvp_of_ba(&cval, val); 677 | 678 | caml_release_runtime_system(); 679 | ret = Val_int(mdb_cmp( 680 | unhide(txn), 681 | Unsigned_int_val(dbi), 682 | &ckey, 683 | &cval)); 684 | caml_acquire_runtime_system(); 685 | 686 | return ret; 687 | } 688 | 689 | CAMLprim value mdbs_dcmp(value txn, value dbi, value key, value val) 690 | { 691 | MDB_val ckey, cval; 692 | int ret; 693 | 694 | mvp_of_ba(&ckey, key); 695 | mvp_of_ba(&cval, val); 696 | 697 | caml_release_runtime_system(); 698 | ret = Val_int(mdb_dcmp( 699 | unhide(txn), 700 | Unsigned_int_val(dbi), 701 | &ckey, 702 | &cval)); 703 | caml_acquire_runtime_system(); 704 | 705 | return ret; 706 | } 707 | -------------------------------------------------------------------------------- /tests/bench.ml: -------------------------------------------------------------------------------- 1 | open Lmdb 2 | 3 | let env = 4 | Env.create Rw 5 | ~flags:Env.Flags.(no_subdir + no_sync + write_map + no_lock + no_mem_init) 6 | ~map_size:104857600 7 | ~max_maps:10 8 | "/tmp/lmdb_test.db" 9 | 10 | let benchmark repeat = 11 | let errors = ref 0 in 12 | 13 | let bench name conv_key conv_val key value n = 14 | let map = Map.(create Nodup ~key:conv_key ~value:conv_val) env ~name in 15 | let bench map cycles = 16 | let open Map in 17 | for i=0 to cycles-1 do 18 | put map (key i) (value i) 19 | done; 20 | for i=0 to cycles-1 do 21 | let v = get map (key i) in 22 | if (v <> value i) 23 | then incr errors; 24 | done; 25 | drop ~delete:false map; 26 | in 27 | name, bench map, n 28 | in 29 | 30 | let open Benchmark in 31 | let samples = 32 | let n = 500 in 33 | throughputN ~repeat 1 34 | [ bench "string" Conv.string Conv.string string_of_int string_of_int n 35 | ; bench "int32_be" Conv.int32_be Conv.string Int32.of_int string_of_int n 36 | ; bench "int32_le" Conv.int32_le Conv.string Int32.of_int string_of_int n 37 | ; bench "int64_be" Conv.int64_be Conv.string Int64.of_int string_of_int n 38 | ; bench "int64_le" Conv.int64_le Conv.string Int64.of_int string_of_int n 39 | ] 40 | in 41 | tabulate samples; 42 | !errors 43 | 44 | let () = 45 | let n = 46 | if Array.length Sys.argv = 2 47 | then int_of_string @@ Sys.argv.(1) 48 | else 1 49 | in 50 | assert (benchmark n = 0) 51 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name simple_db) 3 | (modules simple_db) 4 | (libraries lmdb) 5 | ) 6 | 7 | (executable 8 | (name bench) 9 | (modules bench) 10 | (libraries benchmark lmdb) 11 | ) 12 | 13 | (test 14 | (name test) 15 | (modules pr test) 16 | (flags :standard -thread) 17 | (libraries alcotest lmdb threads) 18 | (action 19 | (setenv MALLOC_CHECK_ 3 20 | (setenv MALLOC_PERTURB_ 195 21 | (run %{test} --color=always -q))) 22 | ) 23 | ) 24 | 25 | (alias 26 | (name bench) 27 | (deps bench.exe (universe)) 28 | (action (run ./bench.exe)) 29 | ) 30 | -------------------------------------------------------------------------------- /tests/pr.ml: -------------------------------------------------------------------------------- 1 | open Lmdb 2 | open Alcotest 3 | 4 | let test env = 5 | "Problem reports", 6 | [ "#15", `Slow, begin fun () -> 7 | Env.set_map_size env 104857600; 8 | let t = Map.(create Nodup ~key:Conv.string ~value:Conv.string) env ~name:"pr#15" in 9 | (* Put some entries *) 10 | let rec put_count t = function 11 | | 0 -> () 12 | | count -> 13 | let value_bytes = Bytes.make (10 * 8 * 1024) '1' in 14 | Map.add t (string_of_int count) (Bytes.to_string value_bytes) ; 15 | put_count t (count - 1) 16 | in 17 | let count = 250 in 18 | put_count t count ; 19 | assert ((Map.stat t).entries = count) ; 20 | (* Iterate using cursor and print keys *) 21 | ignore @@ Lmdb.Cursor.go Ro t (fun cur -> 22 | (* Triggering GC here also SEGFAULTs *) 23 | Gc.full_major () ; 24 | let rec print_keys = function 25 | | 0 -> () 26 | | count -> 27 | let key, _ = Cursor.next cur in 28 | print_endline key ; 29 | print_keys (count - 1) 30 | in 31 | print_keys count ); 32 | end 33 | ; "abort txn with new map handles", `Quick, begin fun () -> 34 | let exception Maps of (int,int,[`Uni]) Map.t list in 35 | let rec exhaust ~txn maps i = 36 | match 37 | Map.(create Nodup ~txn 38 | ~key:Conv.int32_be_as_int 39 | ~value:Conv.int32_be_as_int 40 | ~name:("exhaust_" ^ string_of_int i)) env; 41 | with 42 | | map -> exhaust ~txn (map :: maps) (i+1) 43 | | exception e -> 44 | check (testable Fmt.exn (=)) "max_maps exhausted" 45 | (Error ~-30791 (* MDB_DBS_FULL *)) e; 46 | raise (Maps maps) 47 | in 48 | try ignore @@ Txn.go Rw env (fun txn -> exhaust ~txn [] 0) 49 | with Maps maps -> 50 | begin match "none" with 51 | | "close" -> List.iter Map.close maps 52 | | "GC" -> Gc.full_major () 53 | | _ -> () 54 | end; 55 | let map = Map.(create Nodup ~key:Conv.int32_le_as_int ~value:Conv.string) env ~name:"trigger_error" in 56 | ignore @@ Txn.go Rw env Txn.abort; 57 | Gc.full_major (); 58 | Map.drop ~delete:true map 59 | end 60 | ] 61 | -------------------------------------------------------------------------------- /tests/simple_db.ml: -------------------------------------------------------------------------------- 1 | open Lmdb 2 | 3 | let () = 4 | print_endline "create an env" ; 5 | let env = Env.(create Rw ~flags:Flags.no_subdir "/tmp/foo.db") in 6 | 7 | print_endline "create the map" ; 8 | let map = 9 | Map.(create Nodup ~key:Conv.string ~value:Conv.string) env in 10 | 11 | print_endline "put the key-value binding in the map" ; 12 | Map.set map "foo" (read_line ()) ; 13 | 14 | print_endline "get the value from the map" ; 15 | let s = Map.get map "foo" in 16 | print_endline s ; 17 | -------------------------------------------------------------------------------- /tests/test.ml: -------------------------------------------------------------------------------- 1 | open Alcotest 2 | open Lmdb 3 | 4 | let () = 5 | let (s,major,minor,patch) = Lmdb.version in 6 | Printf.printf "Version: %s\nOr: (%i,%i,%i)\nOCaml Version: %s\n%!" 7 | s major minor patch Sys.ocaml_version 8 | 9 | let filename = 10 | let rec tmp_filename base suffix n = 11 | let name = Printf.sprintf "%s.%u%s" base n suffix in 12 | if Sys.file_exists name; 13 | then tmp_filename base suffix (n+1) 14 | else name 15 | in 16 | tmp_filename "lmdb_test" ".db" 0 17 | 18 | let env = 19 | Env.create Rw 20 | ~flags:Env.Flags.(no_subdir + no_sync + no_mem_init) 21 | ~map_size:524288 22 | ~max_maps:10 23 | filename 24 | let () = 25 | at_exit @@ fun () -> 26 | Env.close env; 27 | Sys.remove filename; 28 | Sys.remove (filename ^ "-lock") 29 | 30 | let[@warning "-26-27"] capabilities () = 31 | let map = 32 | Map.(create Nodup 33 | ~key:Conv.int32_be_as_int 34 | ~value:Conv.int32_be_as_int 35 | ~name:"Capabilities") env 36 | in 37 | let env_rw = env in 38 | let env_ro = env in 39 | (* let env_rw = (env_ro :> [ `Read | `Write ] Env.t) in <- FAILS *) 40 | (* ignore @@ (rw :> [ `Read ] Cap.t); <- FAILS *) 41 | (* ignore @@ (ro :> [ `Read | `Write ] cap); <- FAILS *) 42 | ignore @@ Txn.go Rw env_rw ?txn:None @@ fun txn_rw -> 43 | let txn_ro = (txn_rw :> [ `Read ] Txn.t) in 44 | Map.add ~txn:txn_rw map 4 4; 45 | (* Map.add ~txn:txn_ro map 4 4; <- FAILS *) 46 | assert (Map.get ~txn:txn_rw map 4 = 4); 47 | assert (Map.get ~txn:txn_ro map 4 = 4); 48 | Cursor.go Ro map 49 | ~txn:(txn_rw :> [ `Read ] Txn.t) @@ fun cursor -> 50 | assert (Cursor.get cursor 4 = 4); 51 | (* Cursor.first_dup cursor; <- FAILS *) 52 | ;; 53 | 54 | 55 | let check_kv = check (pair int int) 56 | 57 | let test_types = 58 | let map = 59 | Map.(create Nodup 60 | ~key:Conv.int32_be_as_int 61 | ~value:Conv.int32_be_as_int 62 | ~name:"Capabilities") env 63 | in 64 | "types", 65 | [ "value restriction", `Quick, begin fun () -> 66 | ignore @@ Txn.go Rw ?txn:None env @@ fun txn -> 67 | Map.stat ~txn map |> ignore; 68 | Map.add ~txn map 1 1; 69 | end 70 | ; "can read from writable", `Quick, begin fun () -> 71 | ignore @@ Txn.go Rw env 72 | (fun (txn : [> `Write] Txn.t) -> Map.stat ~txn map |> ignore); 73 | end 74 | ; "ro txn on rw env", `Quick, begin fun () -> 75 | Txn.go Ro env ignore |> ignore 76 | end 77 | ] 78 | 79 | let unimap = 80 | Map.(create Nodup 81 | ~key:Conv.int32_be_as_int 82 | ~value:Conv.int32_be_as_int 83 | ~name:"Nodup") env 84 | and dupmap = 85 | Map.(create Dup 86 | ~key:Conv.int32_be_as_int 87 | ~value:Conv.int32_be_as_int 88 | ~name:"Dup") env 89 | and unimap_filled = 90 | Map.(create Nodup 91 | ~key:Conv.int32_be_as_int 92 | ~value:Conv.int32_be_as_int 93 | ~name:"NodupFilled") env 94 | and dupmap_filled = 95 | Map.(create Dup 96 | ~key:Conv.int32_be_as_int 97 | ~value:Conv.int32_be_as_int 98 | ~name:"DupFilled") env 99 | 100 | let () = 101 | let rec loop n = 102 | if n <= 536870912 then begin 103 | Map.(add unimap_filled ~flags:Flags.append_dup) n n; 104 | loop (n * 2); 105 | end 106 | in loop 12; 107 | 108 | let rec loop n = 109 | if n <= 536870912 then begin 110 | let rec loop_dup m = 111 | if m <= 536870912 then begin 112 | Map.(add dupmap_filled ~flags:Flags.append_dup) n m; 113 | loop_dup (m * 2); 114 | end 115 | in loop_dup n; 116 | loop (n * 2); 117 | end 118 | in loop 12 119 | 120 | let test_map = 121 | "map", 122 | [ "add uni", `Quick, begin fun () -> 123 | (try Map.remove unimap 4285 with Not_found -> ()); 124 | Map.add unimap 4285 42; 125 | Map.get unimap 4285 |> check int "check after add" 42; 126 | check_raises "key collision" Exists 127 | (fun () -> Map.add unimap 4285 42); 128 | end 129 | ; "add dup", `Quick, begin fun () -> 130 | (try Map.remove unimap 4285 with Not_found -> ()); 131 | Map.add dupmap 4285 42; 132 | Map.add dupmap 4285 43; 133 | Map.get dupmap 4285 |> check int "check after add" 42; 134 | check_raises "key collision" Exists 135 | (fun () -> Map.(add ~flags:Flags.no_overwrite) dupmap 4285 45); 136 | check_raises "value collision" Exists 137 | (fun () -> Map.(add ~flags:Flags.no_dup_data) dupmap 4285 42); 138 | end 139 | ; "set uni", `Quick, begin fun () -> 140 | Map.set unimap 4285 1; 141 | Map.set unimap 4285 2; 142 | Map.get unimap 4285 |> check int "set overwrites" 2; 143 | end 144 | ; "set dup", `Quick, begin fun () -> 145 | Map.set dupmap 4285 1; 146 | Map.set dupmap 4285 2; 147 | Map.get dupmap 4285 |> check int "set overwrites" 2; 148 | end 149 | ; "get uni", `Quick, begin fun () -> 150 | Map.set unimap 4285 1; 151 | Map.get unimap 4285 |> check int "correct read" 1; 152 | end 153 | ; "get dup", `Quick, begin fun () -> 154 | Map.set dupmap 4285 1; 155 | Map.add dupmap 4285 2; 156 | Map.get dupmap 4285 |> check int "get returns first value" 1; 157 | end 158 | ; "remove", `Quick, begin fun () -> 159 | Map.set unimap 4285 1; 160 | Map.remove unimap 4285; 161 | check_raises "removed" Not_found (fun () -> Map.get unimap 4285 |> ignore) 162 | end 163 | ; "close", `Quick, begin fun () -> 164 | let map = 165 | Map.(create Nodup 166 | ~key:Conv.int32_be_as_int 167 | ~value:Conv.int32_be_as_int 168 | ~name:"close") env 169 | in 170 | Map.close map; 171 | check_raises "closed map" (Invalid_argument "Lmdb") 172 | (fun () -> Map.set map 0 0) 173 | end 174 | ] 175 | ;; 176 | 177 | let test_cursor = 178 | "cursor", 179 | [ "fold_left uni", `Quick, begin fun () -> 180 | Cursor.fold_left 12 unimap_filled 181 | ~f:begin fun n key value -> 182 | check int "key" n key; 183 | check int "values" n value; 184 | (n * 2) 185 | end 186 | |> check int "last_key" 805306368 187 | end 188 | ; "fold_right uni", `Quick, begin fun () -> 189 | Cursor.fold_right unimap_filled 402653184 190 | ~f:begin fun key value n -> 191 | check int "key" n key; 192 | check int "values" n value; 193 | (n / 2) 194 | end 195 | |> check int "last_key" 6 196 | end 197 | ; "iter uni", `Quick, begin fun () -> 198 | let n = ref 12 in 199 | Cursor.iter unimap_filled 200 | ~f:begin fun key value -> 201 | check int "key" !n key; 202 | check int "values" !n value; 203 | n := value * 2; 204 | end; 205 | check int "last_kv" 805306368 !n 206 | end 207 | ; "fold_left dup", `Quick, begin fun () -> 208 | Cursor.fold_left (12, 12) dupmap_filled 209 | ~f:begin fun (n,m) key value -> 210 | check_kv "kv pair" (n,m) (key,value); 211 | if m*2 <= 536870912 212 | then (n, m * 2) 213 | else (n * 2, n * 2) 214 | end 215 | |> fst |> check int "last_key" 805306368 216 | end 217 | ; "fold_right dup", `Quick, begin fun () -> 218 | Cursor.fold_right dupmap_filled (402653184, 402653184) 219 | ~f:begin fun key value (n,m) -> 220 | check_kv "kv pair" (n,m) (key,value); 221 | if m > n 222 | then (n, m / 2) 223 | else (n / 2, 402653184) 224 | end 225 | |> fst |> check int "last_key" 6 226 | end 227 | ; "iter dup", `Quick, begin fun () -> 228 | let kv = ref (12,12) in 229 | Cursor.iter dupmap_filled 230 | ~f:begin fun key value -> 231 | check_kv "kv pair" !kv (key,value); 232 | Printf.eprintf "%u %u\n" key value; 233 | if value*2 <= 536870912 234 | then kv := (key, value * 2) 235 | else kv := (key * 2, key * 2) 236 | end; 237 | check_kv "last_kv" (805306368,805306368) !kv 238 | end 239 | ; "fold_left_all", `Quick, begin fun () -> 240 | Cursor.fold_left_all 12 dupmap_filled 241 | ~f:begin fun n key values -> 242 | check int "key" n key; 243 | let rec loop_dup i m = 244 | if m <= 536870912 then begin 245 | check int "dup" m values.(i); 246 | loop_dup (i+1) (m * 2); 247 | end 248 | else check int "no extra dups" i (Array.length values) 249 | in loop_dup 0 key; 250 | (key * 2) 251 | end 252 | |> check int "last_key" 805306368 253 | end 254 | ; "fold_right_all", `Quick, begin fun () -> 255 | Cursor.fold_right_all dupmap_filled 402653184 256 | ~f:begin fun key values n -> 257 | check int "key" n key; 258 | let rec loop_dup i m = 259 | if m <= 536870912 then begin 260 | check int "dup" m values.(i); 261 | loop_dup (i+1) (m * 2); 262 | end 263 | else check int "no extra dups" i (Array.length values) 264 | in loop_dup 0 key; 265 | (key / 2) 266 | end 267 | |> check int "last_key" 6 268 | end 269 | ; "iter_all", `Quick, begin fun () -> 270 | let n = ref 12 in 271 | Cursor.iter_all dupmap_filled 272 | ~f:begin fun key values -> 273 | check int "key" !n key; 274 | let rec loop_dup i m = 275 | if m <= 536870912 then begin 276 | check int "dup" m values.(i); 277 | loop_dup (i+1) (m * 2); 278 | end 279 | else check int "no extra dups" i (Array.length values) 280 | in loop_dup 0 key; 281 | n := (key * 2) 282 | end; 283 | check int "last_key" 805306368 !n 284 | end 285 | ; "add uni", `Quick, begin fun () -> 286 | (try Map.remove unimap 4285 with Not_found -> ()); 287 | Cursor.go Rw unimap @@ fun cursor -> 288 | Cursor.add cursor 4285 42; 289 | Cursor.get cursor 4285 |> check int "check after set" 42; 290 | check_raises "key collision" Exists 291 | (fun () -> Cursor.add cursor 4285 42); 292 | end 293 | ; "add dup", `Quick, begin fun () -> 294 | (try Map.remove dupmap 4285 with Not_found -> ()); 295 | Cursor.go Rw dupmap @@ fun cursor -> 296 | Cursor.add cursor 4285 42; 297 | Cursor.add cursor 4285 43; 298 | Cursor.get cursor 4285 |> check int "check after add" 42; 299 | check_raises "key collision" Exists 300 | (fun () -> Cursor.(add ~flags:Flags.no_overwrite) cursor 4285 45); 301 | check_raises "value collision" Exists 302 | (fun () -> Cursor.(add ~flags:Flags.no_dup_data) cursor 4285 42); 303 | end 304 | ; "set uni", `Quick, begin fun () -> 305 | Cursor.go Rw unimap @@ fun cursor -> 306 | Cursor.set cursor 4285 1; 307 | Cursor.set cursor 4285 2; 308 | Cursor.get cursor 4285 |> check int "set overwrites" 2; 309 | end 310 | ; "set dup", `Quick, begin fun () -> 311 | Cursor.go Rw dupmap @@ fun cursor -> 312 | Cursor.set cursor 4285 1; 313 | Cursor.set cursor 4285 2; 314 | Cursor.get cursor 4285 |> check int "set overwrites" 2; 315 | end 316 | ; "get uni", `Quick, begin fun () -> 317 | Cursor.go Rw unimap @@ fun cursor -> 318 | Cursor.set cursor 4285 1; 319 | Cursor.get cursor 4285 |> check int "correct read" 1; 320 | end 321 | ; "get dup", `Quick, begin fun () -> 322 | Cursor.go Rw dupmap @@ fun cursor -> 323 | Cursor.set cursor 4285 1; 324 | Cursor.add cursor 4285 2; 325 | Cursor.get cursor 4285 |> check int "get returns first value" 1; 326 | end 327 | ; "remove", `Quick, begin fun () -> 328 | Cursor.go Rw unimap @@ fun cursor -> 329 | Cursor.set cursor 4285 1; 330 | Cursor.remove cursor; 331 | check_raises "removed" Not_found 332 | (fun () -> Cursor.get cursor 4285 |> ignore) 333 | end 334 | ; "walk uni", `Quick, begin fun () -> 335 | let open Cursor in 336 | go Rw unimap ?txn:None @@ fun cursor -> 337 | for i=0 to 9 do Cursor.add cursor i i done; 338 | first cursor |> check_kv "first" (0,0); 339 | check_raises "walk before first" Not_found 340 | (fun () -> prev cursor |> ignore); 341 | next_nodup cursor |> check_kv "next_nodup" (1,1); 342 | seek cursor 5 |> check_kv "seek 5" (5,5); 343 | prev cursor |> check_kv "prev" (4,4); 344 | current cursor |> check_kv "current" (4,4); 345 | remove cursor; 346 | current cursor |> check_kv "shift after remove" (5,5); 347 | next_nodup cursor |> check_kv "next_nodup" (6,6); 348 | replace cursor 4; (* delete (6,6), add (6,4) *) 349 | current cursor |> check_kv "replace" (6,4); 350 | last cursor |> ignore; 351 | check_raises "walking beyond last key" Not_found 352 | (fun () -> next cursor |> ignore); 353 | end 354 | ; "walk dup", `Quick, begin fun () -> 355 | let open Cursor in 356 | go Rw dupmap ?txn:None @@ fun cursor -> 357 | for i=0 to 9 do add cursor i i done; 358 | for i=0 to 9 do add cursor 10 i done; 359 | prev cursor |> check_kv "prev" (10,8); 360 | next cursor |> check_kv "next" (10,9); 361 | first_dup cursor |> check int "first_dup" 0; 362 | next_dup cursor |> check int "next_dup" 1; 363 | seek_dup cursor 10 5; 364 | current cursor |> check_kv "seek 5" (10,5); 365 | prev cursor |> check_kv "prev" (10,4); 366 | current cursor |> check_kv "current" (10,4); 367 | remove cursor; 368 | current cursor |> check_kv "cursor moved forward after remove" (10,5); 369 | first_dup cursor |> check int "first" 0; 370 | check_raises "fail when walking before first dup" Not_found 371 | (fun () -> prev_dup cursor |> ignore); 372 | last_dup cursor |> check int "last" 9; 373 | check_raises "fail when walking beyond last dup" Not_found 374 | (fun () -> next_dup cursor |> ignore); 375 | seek_dup cursor 10 7; 376 | current cursor |> check_kv "seek_dup" (10,7); 377 | end 378 | ; "first/last get first/last values", `Quick, begin fun () -> 379 | let open Cursor in 380 | go Rw dupmap ?txn:None @@ fun cursor -> 381 | set cursor ~flags:Flags.(none) 0 0; 382 | add cursor ~flags:Flags.(append_dup) 0 1; 383 | add cursor ~flags:Flags.(append_dup) 0 2; 384 | add cursor ~flags:Flags.(append + append_dup) 536870913 5; 385 | add cursor ~flags:Flags.(append_dup) 536870913 6; 386 | add cursor ~flags:Flags.(append_dup) 536870913 7; 387 | first cursor |> check_kv "first value" (0,0); 388 | last cursor |> check_kv "last value" (536870913,7); 389 | end 390 | ; "*_all", `Quick, begin fun () -> 391 | let open Cursor in 392 | go Rw dupmap_filled ?txn:None @@ fun cursor -> 393 | get_all cursor 100663296 |> check (array int) "get_all" [|100663296; 201326592; 402653184|]; 394 | current cursor |> check_kv "cursor after get_all" (100663296, 402653184); 395 | last_all cursor |> snd |> check (array int) "last_all" [|402653184|]; 396 | prev_all cursor |> snd |> check (array int) "prev_all" [|201326592; 402653184|]; 397 | prev_nodup cursor |> ignore; 398 | next_all cursor |> snd |> check (array int) "next_all" [|201326592; 402653184|]; 399 | prev_nodup cursor |> ignore; 400 | next_nodup cursor |> ignore; 401 | current cursor |> check_kv "cursor after prev_all" (201326592, 201326592;); 402 | current_all cursor |> snd |> check (array int) "current_all" [|201326592; 402653184|]; 403 | current cursor |> check_kv "cursor after current_all" (201326592, 402653184); 404 | current cursor |> check_kv "cursor after next_all" (201326592, 402653184); 405 | first_all cursor |> snd |> check (array int) "first_all" 406 | [|12; 24; 48; 96; 192; 384; 768; 1536; 3072; 6144; 12288; 24576; 49152 407 | ; 98304; 196608; 393216; 786432; 1572864; 3145728; 6291456; 12582912 408 | ; 25165824; 50331648; 100663296; 201326592; 402653184|]; 409 | current cursor |> check_kv "cursor after first_all" (12, 402653184); 410 | end 411 | ; "get_multiple", `Quick, begin fun () -> 412 | (try Map.remove unimap 0 with Not_found -> ()); 413 | let open Cursor in 414 | go Rw dupmap ?txn:None @@ fun cursor -> 415 | seek cursor 0 |> ignore; 416 | remove cursor ~all:true; 417 | for i=0 to 65536 do 418 | add cursor ~flags:Flags.append_dup 0 i 419 | done; 420 | let values = get_all cursor 0 in 421 | for i=0 to 65536 do 422 | if i <> values.(i) 423 | then check int "order in many dups got with get_all" i values.(i) 424 | done; 425 | end 426 | ; "wrong map", `Quick, 427 | begin fun () -> 428 | let map2 = 429 | Map.(create Nodup 430 | ~key:Conv.int32_be_as_int 431 | ~value:Conv.int32_be_as_int 432 | ~name:"wrongmap") env 433 | in 434 | check_raises "wrong cursor" (Invalid_argument "Lmdb.Cursor.fold: Got cursor for wrong map") begin fun () -> 435 | Cursor.go Ro map2 @@ fun cursor -> 436 | Cursor.fold_left ~cursor () unimap ~f:(fun _ _ _ -> ()); 437 | end; 438 | end 439 | ] 440 | ;; 441 | 442 | let test_int = 443 | let make_test name conv = 444 | name, `Quick, 445 | begin fun () -> 446 | let map = 447 | Map.(create Dup 448 | ~key:conv 449 | ~value:conv 450 | ~name) env 451 | in 452 | let rec loop n = 453 | if n < 1073741823 then begin 454 | (try Map.(add ~flags:Flags.append map n n) 455 | with Exists -> fail "Ordering on keys"); 456 | (try Map.(add ~flags:Flags.append_dup map 1 n) 457 | with Exists -> fail "Ordering on values"); 458 | loop (n / 3 * 4); 459 | end 460 | in loop 12; 461 | Map.drop ~delete:true map; 462 | end 463 | in 464 | "Int", 465 | [ make_test "int32_be" Conv.int32_be_as_int 466 | ; make_test "int32_le" Conv.int32_le_as_int 467 | ; make_test "int64_be" Conv.int64_be_as_int 468 | ; make_test "int64_le" Conv.int64_le_as_int 469 | ] 470 | 471 | let test_stress = 472 | "threaded GC stress", 473 | let stress duration () = 474 | let map = 475 | Map.(create Nodup 476 | ~key:Conv.string 477 | ~value:Conv.string 478 | ~name:"map.string") env 479 | in 480 | let mutex = Mutex.create () in 481 | let errors = ref 0 in 482 | let running = ref true in 483 | let n = 100 in 484 | let rec worker thread_id = 485 | let offset = thread_id * n in 486 | for i = offset to offset + n - 1 do 487 | let dig = Digest.string @@ string_of_int i in 488 | Map.add map dig dig 489 | done; 490 | for i = offset to offset + n - 1 do 491 | let dig = Digest.string @@ string_of_int i in 492 | if Map.get map dig <> dig 493 | then begin 494 | Mutex.lock mutex; 495 | incr errors; 496 | Mutex.unlock mutex; 497 | end 498 | else Map.remove map dig 499 | done; 500 | if !running then worker thread_id 501 | in 502 | let rec stress_gc () = 503 | Gc.minor (); 504 | Thread.yield (); 505 | if !running then stress_gc () 506 | in 507 | Gc.full_major (); 508 | Thread.create stress_gc () |> ignore; 509 | let threads = Array.init 8 (Thread.create worker) in 510 | Thread.delay duration; 511 | running := false; 512 | Array.iter Thread.join threads; 513 | check int "wrong reads" 0 !errors; 514 | Map.drop ~delete:true map 515 | in 516 | [ "stress 1s", `Quick, stress 1. 517 | (*; "stress 500s", `Slow, stress 500. too slow *) 518 | ] 519 | 520 | let test_regress = 521 | "regression tests", 522 | [ "unnamed dbi", `Quick, begin fun () -> 523 | Map.(open_existing Nodup ~key:Conv.string ~value:Conv.string) env 524 | |> ignore 525 | end 526 | ; "dup unnamed dbi", `Quick, begin fun () -> 527 | check_raises "no duplicates on unnamed map" 528 | (Invalid_argument "Lmdb.Map.create: The unnamed map does not support duplicates") 529 | @@ fun () -> 530 | let unnamed_dup = 531 | Map.(open_existing Dup ~key:Conv.string ~value:Conv.string) env 532 | in 533 | check bool "compare dups" true (Map.compare_val unnamed_dup "5" "1" > 0); 534 | Cursor.go Rw unnamed_dup @@ fun cursor -> 535 | Cursor.add cursor "dup_entry" "1"; 536 | Cursor.add cursor "dup_entry" "2"; 537 | check (pair string (array string)) "dup entries" ("dup entry", [|"1";"2"|]) 538 | (Cursor.current_all cursor); 539 | end 540 | ] 541 | 542 | let test_txn = 543 | "transaction", 544 | let map = Map.(create Nodup ~key:Conv.int32_le_as_int ~value:Conv.string) env ~name:"double txn_abort" in 545 | [ "abort", `Quick, begin fun () -> 546 | ignore @@ Txn.go Rw env begin fun txn -> 547 | Map.add ~txn map 13 "blub"; 548 | Txn.abort txn; 549 | end; 550 | check_raises "expecting Not_found" Not_found 551 | (fun () -> Map.get map 13 |> ignore); 552 | end 553 | ; "wrong envirronment", `Quick, 554 | begin fun () -> 555 | let env2 = 556 | Env.create Ro 557 | ~flags:Env.Flags.(no_subdir + no_sync + no_lock + no_mem_init) 558 | filename 559 | in 560 | check_raises "wrong txn" (Invalid_argument "Lmdb: transaction from wrong environment.") begin fun () -> 561 | ignore @@ Txn.go Ro env2 562 | (fun txn -> Map.get ~txn map 0 |> ignore); 563 | end; 564 | Env.close env2; 565 | end 566 | ; "MAP_FULL triggered by txn_commit", `Quick, begin fun () -> 567 | (* mdb_txn_commit may return MDB_MAP_FULL. 568 | * In that case we did call mdb_txn_abort, which resulted in the 569 | * transaction being freed twice. *) 570 | check_raises "expecting Map_full from txn_commit" Map_full begin fun () -> 571 | for i=100 to max_int do 572 | Map.(add ~flags:Flags.append) map i "blub" (* Calls Txn.trivial *) 573 | done 574 | end; 575 | let map_size = Env.(info env).map_size in 576 | Env.set_map_size env (2 * map_size); 577 | check pass "resized map" () (); 578 | Map.add map 1 "blub"; 579 | check pass "add successfull" () (); 580 | Map.drop ~delete:false map; 581 | end 582 | ; "MAP_FULL triggered by Map.add", `Quick, begin fun () -> 583 | check_raises "expecting Map_full from Txn.go" Map_full begin fun () -> 584 | ignore @@ Txn.go Rw env @@ fun txn -> 585 | let bulk = String.make 1024 '#' in 586 | for i=100 to max_int do 587 | Map.(add ~txn ~flags:Flags.append) map i bulk 588 | done 589 | end; 590 | Map.add map 1 "blub"; 591 | check pass "add successfull" () (); 592 | Map.drop ~delete:false map; 593 | end 594 | ; "MAP_FULL not passed on to Txn.go", `Quick, begin fun () -> 595 | check_raises "expecting MDB_BAD_TXN from Txn.go" (Error ~-30782) begin fun () -> 596 | ignore @@ Txn.go Rw env @@ fun txn -> 597 | let bulk = String.make 1024 '#' in 598 | check_raises "expecting Map_full from Map.add" Map_full @@ fun () -> 599 | for i=100 to max_int do 600 | Map.(add ~txn ~flags:Flags.append) map i bulk 601 | done 602 | end; 603 | Map.add map 1 "blub"; 604 | check pass "add successfull" () (); 605 | end 606 | ; "DBS_FULL", `Quick, begin fun () -> 607 | let rec exhaust ~txn maps i = 608 | match 609 | Map.(create Nodup ~txn 610 | ~key:Conv.int32_be_as_int 611 | ~value:Conv.int32_be_as_int 612 | ~name:("exhaust_" ^ string_of_int i)) env; 613 | with 614 | | map -> exhaust ~txn (map :: maps) (i+1) 615 | | exception e -> 616 | (* 617 | List.iter Map.close maps; 618 | lmdb manual says: 619 | Do not close a handle if an existing transaction has modified 620 | its database. 621 | This is true for us here, too, since we just created the 622 | databases. Committing the transaction after closing the handles 623 | would fail with MDB_BAD_DBI, because mdb_txn_commit() would try to 624 | commit the map handles we already closed. The story might be 625 | different for map handles that were used read-only. 626 | *) 627 | check (testable Fmt.exn (=)) "max_maps exhausted" 628 | (Error ~-30791 (* MDB_DBS_FULL *)) e; 629 | maps 630 | in 631 | match Txn.go Rw env (fun txn -> exhaust ~txn [] 0) with 632 | | None -> () 633 | | Some maps -> 634 | (* 635 | Without cleanup later map creations will obviously fail with 636 | MDB_DBS_FULL. 637 | *) 638 | match "close" with 639 | | "close" -> List.iter Map.close maps 640 | | "GC" -> Gc.full_major () 641 | | _ -> () 642 | end 643 | ; "DBS_FULL - recycle ro map slots", `Quick, begin fun () -> 644 | for i=0 to 19 do 645 | Map.(create Nodup 646 | ~key:Conv.int32_be_as_int 647 | ~value:Conv.int32_be_as_int 648 | ~name:("recycle_" ^ string_of_int i)) env 649 | |> Map.close 650 | done; 651 | let rec exhaust ~txn maps i = 652 | match 653 | Map.(create Nodup ~txn 654 | ~key:Conv.int32_be_as_int 655 | ~value:Conv.int32_be_as_int) 656 | ~name:("recycle_" ^ string_of_int i) 657 | env; 658 | with 659 | | map -> exhaust ~txn (map :: maps) (i+1) 660 | | exception e -> 661 | check (testable Fmt.exn (=)) "max_maps exhausted" 662 | (Error ~-30791 (* MDB_DBS_FULL *)) e; 663 | maps 664 | in 665 | ignore @@ Txn.go Rw env begin fun txn -> 666 | let maps = exhaust ~txn [] 0 in 667 | let n = List.length maps in 668 | List.iter Map.close maps; 669 | let maps = exhaust ~txn [] n in 670 | List.iter Map.close maps 671 | end 672 | end 673 | ] 674 | 675 | let () = 676 | run "Lmdb" 677 | [ "capabilities", [ "capabilities", `Quick, capabilities ] 678 | ; test_types 679 | ; test_map 680 | ; test_cursor 681 | ; test_int 682 | ; test_regress 683 | ; test_txn 684 | ; test_stress 685 | ; Pr.test env 686 | ] 687 | --------------------------------------------------------------------------------