From 03ab5b5471a21954be76755d25e189121db9504a Mon Sep 17 00:00:00 2001 From: eknauel Date: Fri, 17 Sep 2004 10:50:50 +0000 Subject: [PATCH] *** empty log message *** --- .gitignore | 28 ++ AUTHORS | 2 + COPYING | 26 ++ ChangeLog | 0 INSTALL | 229 +++++++++++++ Makefile.am | 1 + NEWS | 0 README | 0 c/Makefile.am | 8 + c/bdb.c | 797 ++++++++++++++++++++++++++++++++++++++++++++ c/bdb.h | 48 +++ configure.in | 39 +++ pkg-def.scm | 74 ++++ scheme/bdb.scm | 603 +++++++++++++++++++++++++++++++++ scheme/packages.scm | 63 ++++ 15 files changed, 1918 insertions(+) create mode 100644 .gitignore create mode 100644 AUTHORS create mode 100644 COPYING create mode 100644 ChangeLog create mode 100644 INSTALL create mode 100644 Makefile.am create mode 100644 NEWS create mode 100644 README create mode 100644 c/Makefile.am create mode 100644 c/bdb.c create mode 100644 c/bdb.h create mode 100644 configure.in create mode 100644 pkg-def.scm create mode 100644 scheme/bdb.scm create mode 100644 scheme/packages.scm diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..da8168b --- /dev/null +++ b/.gitignore @@ -0,0 +1,28 @@ +# CVS default ignores begin +tags +TAGS +.make.state +.nse_depinfo +*~ +\#* +.#* +,* +_$* +*$ +*.old +*.bak +*.BAK +*.orig +*.rej +.del-* +*.a +*.olb +*.o +*.obj +*.so +*.exe +*.Z +*.elc +*.ln +core +# CVS default ignores end diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 0000000..3c112d0 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,2 @@ +Daniel Brintzinger +Eric Knauel diff --git a/COPYING b/COPYING new file mode 100644 index 0000000..59bb642 --- /dev/null +++ b/COPYING @@ -0,0 +1,26 @@ +Copyright (c) 2004 by Eric Knauel +Copyright (c) 2004 by Daniel Brintzinger + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The name of the authors may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 0000000..e69de29 diff --git a/INSTALL b/INSTALL new file mode 100644 index 0000000..54caf7c --- /dev/null +++ b/INSTALL @@ -0,0 +1,229 @@ +Copyright (C) 1994, 1995, 1996, 1999, 2000, 2001, 2002 Free Software +Foundation, Inc. + + This file is free documentation; the Free Software Foundation gives +unlimited permission to copy, distribute and modify it. + +Basic Installation +================== + + These are generic installation instructions. + + The `configure' shell script attempts to guess correct values for +various system-dependent variables used during compilation. It uses +those values to create a `Makefile' in each directory of the package. +It may also create one or more `.h' files containing system-dependent +definitions. Finally, it creates a shell script `config.status' that +you can run in the future to recreate the current configuration, and a +file `config.log' containing compiler output (useful mainly for +debugging `configure'). + + It can also use an optional file (typically called `config.cache' +and enabled with `--cache-file=config.cache' or simply `-C') that saves +the results of its tests to speed up reconfiguring. (Caching is +disabled by default to prevent problems with accidental use of stale +cache files.) + + If you need to do unusual things to compile the package, please try +to figure out how `configure' could check whether to do them, and mail +diffs or instructions to the address given in the `README' so they can +be considered for the next release. If you are using the cache, and at +some point `config.cache' contains results you don't want to keep, you +may remove or edit it. + + The file `configure.ac' (or `configure.in') is used to create +`configure' by a program called `autoconf'. You only need +`configure.ac' if you want to change it or regenerate `configure' using +a newer version of `autoconf'. + +The simplest way to compile this package is: + + 1. `cd' to the directory containing the package's source code and type + `./configure' to configure the package for your system. If you're + using `csh' on an old version of System V, you might need to type + `sh ./configure' instead to prevent `csh' from trying to execute + `configure' itself. + + Running `configure' takes awhile. While running, it prints some + messages telling which features it is checking for. + + 2. Type `make' to compile the package. + + 3. Optionally, type `make check' to run any self-tests that come with + the package. + + 4. Type `make install' to install the programs and any data files and + documentation. + + 5. You can remove the program binaries and object files from the + source code directory by typing `make clean'. To also remove the + files that `configure' created (so you can compile the package for + a different kind of computer), type `make distclean'. There is + also a `make maintainer-clean' target, but that is intended mainly + for the package's developers. If you use it, you may have to get + all sorts of other programs in order to regenerate files that came + with the distribution. + +Compilers and Options +===================== + + Some systems require unusual options for compilation or linking that +the `configure' script does not know about. Run `./configure --help' +for details on some of the pertinent environment variables. + + You can give `configure' initial values for configuration parameters +by setting variables in the command line or in the environment. Here +is an example: + + ./configure CC=c89 CFLAGS=-O2 LIBS=-lposix + + *Note Defining Variables::, for more details. + +Compiling For Multiple Architectures +==================================== + + You can compile the package for more than one kind of computer at the +same time, by placing the object files for each architecture in their +own directory. To do this, you must use a version of `make' that +supports the `VPATH' variable, such as GNU `make'. `cd' to the +directory where you want the object files and executables to go and run +the `configure' script. `configure' automatically checks for the +source code in the directory that `configure' is in and in `..'. + + If you have to use a `make' that does not support the `VPATH' +variable, you have to compile the package for one architecture at a +time in the source code directory. After you have installed the +package for one architecture, use `make distclean' before reconfiguring +for another architecture. + +Installation Names +================== + + By default, `make install' will install the package's files in +`/usr/local/bin', `/usr/local/man', etc. You can specify an +installation prefix other than `/usr/local' by giving `configure' the +option `--prefix=PATH'. + + You can specify separate installation prefixes for +architecture-specific files and architecture-independent files. If you +give `configure' the option `--exec-prefix=PATH', the package will use +PATH as the prefix for installing programs and libraries. +Documentation and other data files will still use the regular prefix. + + In addition, if you use an unusual directory layout you can give +options like `--bindir=PATH' to specify different values for particular +kinds of files. Run `configure --help' for a list of the directories +you can set and what kinds of files go in them. + + If the package supports it, you can cause programs to be installed +with an extra prefix or suffix on their names by giving `configure' the +option `--program-prefix=PREFIX' or `--program-suffix=SUFFIX'. + +Optional Features +================= + + Some packages pay attention to `--enable-FEATURE' options to +`configure', where FEATURE indicates an optional part of the package. +They may also pay attention to `--with-PACKAGE' options, where PACKAGE +is something like `gnu-as' or `x' (for the X Window System). The +`README' should mention any `--enable-' and `--with-' options that the +package recognizes. + + For packages that use the X Window System, `configure' can usually +find the X include and library files automatically, but if it doesn't, +you can use the `configure' options `--x-includes=DIR' and +`--x-libraries=DIR' to specify their locations. + +Specifying the System Type +========================== + + There may be some features `configure' cannot figure out +automatically, but needs to determine by the type of machine the package +will run on. Usually, assuming the package is built to be run on the +_same_ architectures, `configure' can figure that out, but if it prints +a message saying it cannot guess the machine type, give it the +`--build=TYPE' option. TYPE can either be a short name for the system +type, such as `sun4', or a canonical name which has the form: + + CPU-COMPANY-SYSTEM + +where SYSTEM can have one of these forms: + + OS KERNEL-OS + + See the file `config.sub' for the possible values of each field. If +`config.sub' isn't included in this package, then this package doesn't +need to know the machine type. + + If you are _building_ compiler tools for cross-compiling, you should +use the `--target=TYPE' option to select the type of system they will +produce code for. + + If you want to _use_ a cross compiler, that generates code for a +platform different from the build platform, you should specify the +"host" platform (i.e., that on which the generated programs will +eventually be run) with `--host=TYPE'. + +Sharing Defaults +================ + + If you want to set default values for `configure' scripts to share, +you can create a site shell script called `config.site' that gives +default values for variables like `CC', `cache_file', and `prefix'. +`configure' looks for `PREFIX/share/config.site' if it exists, then +`PREFIX/etc/config.site' if it exists. Or, you can set the +`CONFIG_SITE' environment variable to the location of the site script. +A warning: not all `configure' scripts look for a site script. + +Defining Variables +================== + + Variables not defined in a site shell script can be set in the +environment passed to `configure'. However, some packages may run +configure again during the build, and the customized values of these +variables may be lost. In order to avoid this problem, you should set +them in the `configure' command line, using `VAR=value'. For example: + + ./configure CC=/usr/local2/bin/gcc + +will cause the specified gcc to be used as the C compiler (unless it is +overridden in the site shell script). + +`configure' Invocation +====================== + + `configure' recognizes the following options to control how it +operates. + +`--help' +`-h' + Print a summary of the options to `configure', and exit. + +`--version' +`-V' + Print the version of Autoconf used to generate the `configure' + script, and exit. + +`--cache-file=FILE' + Enable the cache: use and save the results of the tests in FILE, + traditionally `config.cache'. FILE defaults to `/dev/null' to + disable caching. + +`--config-cache' +`-C' + Alias for `--cache-file=config.cache'. + +`--quiet' +`--silent' +`-q' + Do not print messages saying which checks are being made. To + suppress all normal output, redirect it to `/dev/null' (any error + messages will still be shown). + +`--srcdir=DIR' + Look for the package's source code in directory DIR. Usually + `configure' can determine that directory automatically. + +`configure' also accepts some other, not widely useful, options. Run +`configure --help' for more details. + diff --git a/Makefile.am b/Makefile.am new file mode 100644 index 0000000..75a8c9d --- /dev/null +++ b/Makefile.am @@ -0,0 +1 @@ +SUBDIRS = c \ No newline at end of file diff --git a/NEWS b/NEWS new file mode 100644 index 0000000..e69de29 diff --git a/README b/README new file mode 100644 index 0000000..e69de29 diff --git a/c/Makefile.am b/c/Makefile.am new file mode 100644 index 0000000..a575001 --- /dev/null +++ b/c/Makefile.am @@ -0,0 +1,8 @@ +INCLUDES = -I@top_srcdir@/c + +libsys_LTLIBRARIES= libscshbdb.la + +libscshbdb_la_SOURCES=bdb.c +libscshbdb_la_LDFLAGS=-avoid-version -module +libscshbdb_la_DEPENDENCIES= + diff --git a/c/bdb.c b/c/bdb.c new file mode 100644 index 0000000..0344c61 --- /dev/null +++ b/c/bdb.c @@ -0,0 +1,797 @@ +#include "bdb.h" + +/* initialise flag constants */ +static s48_value scheme_DB_RPCCLIENT = S48_FALSE; +static s48_value scheme_DB_INIT_LOCK = S48_FALSE; +static s48_value scheme_DB_JOINENV = S48_FALSE; +static s48_value scheme_DB_INIT_MPOOL = S48_FALSE; +static s48_value scheme_DB_INIT_LOG = S48_FALSE; +static s48_value scheme_DB_INIT_REP = S48_FALSE; +static s48_value scheme_DB_INIT_TXN = S48_FALSE; +static s48_value scheme_DB_RECOVER = S48_FALSE; +static s48_value scheme_DB_RECOVER_FATAL = S48_FALSE; +static s48_value scheme_DB_USE_ENVIRON = S48_FALSE; +static s48_value scheme_DB_USE_ENVIRON_ROOT = S48_FALSE; +static s48_value scheme_DB_CREATE = S48_FALSE; +static s48_value scheme_DB_LOCKDOWN = S48_FALSE; +static s48_value scheme_DB_PRIVATE = S48_FALSE; +static s48_value scheme_DB_SYSTEM_MEM = S48_FALSE; +static s48_value scheme_DB_THREAD = S48_FALSE; +static s48_value scheme_DB_XA_CREATE = S48_FALSE; +static s48_value scheme_DB_AUTO_COMMIT = S48_FALSE; +static s48_value scheme_DB_DIRTY_READ = S48_FALSE; +static s48_value scheme_DB_EXCL = S48_FALSE; +static s48_value scheme_DB_NOMMAP = S48_FALSE; +static s48_value scheme_DB_RDONLY = S48_FALSE; +static s48_value scheme_DB_TRUNCATE = S48_FALSE; +static s48_value scheme_DB_NOSYNC = S48_FALSE; +static s48_value scheme_DB_CONSUME = S48_FALSE; +static s48_value scheme_DB_CONSUME_WAIT = S48_FALSE; +static s48_value scheme_DB_GET_BOTH = S48_FALSE; +static s48_value scheme_DB_RMW = S48_FALSE; +static s48_value scheme_DB_MULTIPLE = S48_FALSE; +static s48_value scheme_DB_SET_RECNO = S48_FALSE; +static s48_value scheme_DB_APPEND = S48_FALSE; +static s48_value scheme_DB_NODUPDATA = S48_FALSE; +static s48_value scheme_DB_NOOVERWRITE = S48_FALSE; +static s48_value scheme_DB_CURRENT = S48_FALSE; +static s48_value scheme_DB_FIRST = S48_FALSE; +static s48_value scheme_DB_WRITECURSOR = S48_FALSE; +static s48_value scheme_DB_GET_BOTH_RANGE = S48_FALSE; +static s48_value scheme_DB_GET_RECNO = S48_FALSE; +static s48_value scheme_DB_JOIN_ITEM = S48_FALSE; +static s48_value scheme_DB_LAST = S48_FALSE; +static s48_value scheme_DB_NEXT = S48_FALSE; +static s48_value scheme_DB_NEXT_DUP = S48_FALSE; +static s48_value scheme_DB_NEXT_NODUP = S48_FALSE; +static s48_value scheme_DB_PREV = S48_FALSE; +static s48_value scheme_DB_SET = S48_FALSE; +static s48_value scheme_DB_SET_RANGE = S48_FALSE; +static s48_value scheme_DB_MULTIPLE_KEY = S48_FALSE; +static s48_value scheme_DB_TXN_NOSYNC = S48_FALSE; +static s48_value scheme_DB_TXN_NOWAIT = S48_FALSE; +static s48_value scheme_DB_TXN_SYNC = S48_FALSE; + +/* initialise DB_TYPES */ +static s48_value scheme_DB_BTREE = S48_FALSE; +static s48_value scheme_DB_HASH = S48_FALSE; +static s48_value scheme_DB_QUEUE = S48_FALSE; +static s48_value scheme_DB_RECNO = S48_FALSE; +static s48_value scheme_DB_UNKNOWN = S48_FALSE; + +s48_value scsh_enter_db(DB *h) +{ + s48_value rec = S48_FALSE; + + S48_DECLARE_GC_PROTECT(1); + S48_GC_PROTECT_1(rec); + + rec = s48_make_record(bdb_db_record_type); + S48_RECORD_SET(rec, 0, s48_enter_integer((long) h)); + + S48_GC_UNPROTECT(); + return rec; +} + +s48_value scsh_enter_txnid(DB_TXN *txnid) +{ + s48_value rec = S48_FALSE; + + S48_DECLARE_GC_PROTECT(1); + S48_GC_PROTECT_1(rec); + + rec = s48_make_record(bdb_txn_record_type); + S48_RECORD_SET(rec, 0, s48_enter_integer((long) txnid)); + + S48_GC_UNPROTECT(); + return rec; +} + +s48_value scsh_enter_cursor(DBC *dbc) +{ + s48_value rec = S48_FALSE; + + S48_DECLARE_GC_PROTECT(1); + S48_GC_PROTECT_1(rec); + + rec = s48_make_record(bdb_dbc_record_type); + S48_RECORD_SET(rec, 0, s48_enter_integer((long) dbc)); + + S48_GC_UNPROTECT(); + return rec; +} + +s48_value scsh_enter_dbenv(DB_ENV *h) +{ + s48_value rec = S48_FALSE; + + S48_DECLARE_GC_PROTECT(1); + S48_GC_PROTECT_1(rec); + + rec = s48_make_record(bdb_env_record_type); + S48_RECORD_SET(rec, 0, s48_enter_integer((long) h)); + + S48_GC_UNPROTECT(); + return rec; +} + +/* BDB operations */ + +/* database environment */ + +/* create an environment handle */ +s48_value scsh_bdb_env_create(s48_value sflags) +{ + + DB_ENV *dbenv; + int res; + u_int32_t flags = S48_FALSE; + + S48_DECLARE_GC_PROTECT(1); + S48_GC_PROTECT_1(sflags); + flags = s48_extract_integer(sflags); + S48_GC_UNPROTECT(); + + res = db_env_create(&dbenv, flags); + + CHECK_BDB_RESULT_CODE(res); + return scsh_enter_env(dbenv); +} + +/* close an environment */ +s48_value scsh_bdb_env_close(s48_value env, s48_value sflags) +{ + int res; + DB_ENV *dbenv; + u_int32_t flags; + + S48_DECLARE_GC_PROTECT(2); + S48_GC_PROTECT_2(env, sflags); + + dbenv = scsh_extract_dbenv(env); + flags = s48_extract_integer(sflags); + S48_GC_UNPROTECT(); + + res = dbenv->close(dbenv, flags); + CHECK_BDB_RESULT_CODE(res); + return S48_TRUE; +} + +/* remove a database */ +/* s48_value scsh_bdb_dbremove(...) */ +/* { */ +/* DB_ENV->dbremove(); */ +/* } */ + +/* rename a database */ +/* s48_value scsh_bdb_dbrename(...) */ +/* { */ +/* DB_ENV->dbrename(); */ +/* } */ + +/* open an environment */ +s48_value scsh_bdb_env_open(s48_value env_handle, s48_value sdb_home, + s48_value sflags, s48_value smode) +{ + int res, mode; + char *dbhome; + DB_ENV *dbenv; + u_int32_t flags; + + S48_DECLARE_GC_PROTECT(4); + S48_GC_PROTECT_4(env_handle, sdb_home, sflags, smode); + + dbhome = s48_extract_string(sdb_home); + dbenv = scsh_extract_dbenv(env_handle); + mode = s48_extract_integer(smode); + //flags = bdb_extract_flags(sflags); + // as of now default is set to transaction and locking support + flags = DB_CREATE | DB_INIT_LOG | DB_INIT_LOCK | DB_INIT_TXN; + + S48_GC_UNPROTECT(); + + res = dbenv->open(dbenv, dbhome, flags, mode); + CHECK_BDB_RESULT_CODE(res); + + return S48_TRUE; +} + +/* remove an environment */ +s48_value scsh_bdb_env_remove(s48_value db_home, s48_value sflags) +{ + DB_ENV *dbenv; + int res; + char *dbhome; + u_int32_t flags; + + S48_DECLARE_GC_PROTECT(2); + S48_GC_PROTECT_2(db_home, sflags); + dbhome = s48_extract_string(db_home); + flags = s48_extract_integer(sflags); + + S48_GC_UNPROTECT(); + + res = dbenv->remove(dbenv, dbhome, flags); + CHECK_BDB_RESULT_CODE(res); + return S48_TRUE; +} + +/* environment configuration */ + +/* set the environment data directory */ +/* s48_value scsh_bdb_env_set_data_dir(...) */ +/* { */ +/* DB_ENV->set_data_dir(); */ +/* } */ + +/* set the environment cryptographic key */ +/* s48_value scsh_bdb_env_set_encrypt(...) */ +/* { */ +/* DB_ENV->set_encrypt(); */ +/* } */ + +/* create DB - returns dbp handle */ +s48_value scsh_bdb_create(s48_value env, s48_value sflags) +{ + DB *dbp; + DB_ENV *dbenv; + int res; + u_int32_t flags; + + S48_DECLARE_GC_PROTECT(2); + S48_GC_PROTECT_2(env, sflags); + flags = s48_extract_integer(sflags); + dbenv = EXTRACT_OPTIONAL_ENV(env); + S48_GC_UNPROTECT(); + + res = db_create(&dbp, dbenv, flags); + CHECK_BDB_RESULT_CODE(res); + return scsh_enter_db(dbp); +} + +/* open DB */ +s48_value scsh_bdb_open(s48_value db, s48_value sfile, s48_value sdatabase, + s48_value stxnid, s48_value stype, s48_value sflags, + s48_value smode) +{ + int res, mode; + char *dbfile; + char *database; + DB *dbp; + DB_TXN *txnid; + DBTYPE type; + u_int32_t flags; + + S48_DECLARE_GC_PROTECT(7); + S48_GC_PROTECT_7(db, sfile, sdatabase, stxnid, stype, sflags, smode); + dbfile = s48_extract_string(sfile); + database = EXTRACT_OPTIONAL_STRING(sdatabase); + dbp = scsh_extract_db(db); + txnid = EXTRACT_OPTIONAL_TXNID(stxnid); + type = s48_extract_integer(stype); + flags = s48_extract_integer(sflags); + mode = s48_extract_integer(smode); + + S48_GC_UNPROTECT(); + + res = dbp->open(dbp, txnid, dbfile, database, type, flags, mode); + CHECK_BDB_RESULT_CODE(res); + return S48_TRUE; +} + +/* close DB */ +s48_value scsh_bdb_close(s48_value db, s48_value sflags) +{ + int res; + DB *dbp; + u_int32_t flags; + + S48_DECLARE_GC_PROTECT(2); + S48_GC_PROTECT_2(db, sflags); + dbp= scsh_extract_db(db); + flags = s48_extract_integer(sflags); + S48_GC_UNPROTECT(); + + res = dbp->close(dbp, flags); + CHECK_BDB_RESULT_CODE(res); + return S48_TRUE; +} + +s48_value scsh_bdb_truncate(s48_value db, s48_value stxnid, s48_value sflags) +{ + int res; + DB *dbp; + u_int32_t flags; + u_int32_t *countp; + DB_TXN *txnid; + + S48_DECLARE_GC_PROTECT(3); + S48_GC_PROTECT_3(db, stxnid, sflags); + dbp= scsh_extract_db(db); + txnid = EXTRACT_OPTIONAL_TXNID(stxnid); + flags = s48_extract_integer(sflags); + S48_GC_UNPROTECT(); + + res = dbp->truncate(dbp, txnid, countp, flags); + CHECK_BDB_RESULT_CODE(res); + return S48_TRUE; +} + +s48_value scsh_bdb_sync(s48_value db) +{ + int res; + DB *dbp; + + S48_DECLARE_GC_PROTECT(1); + S48_GC_PROTECT_1(db); + dbp = scsh_extract_db(db); + S48_GC_UNPROTECT(); + + res = dbp->sync(dbp, 0); + CHECK_BDB_RESULT_CODE(res); + return S48_TRUE; +} + +/* DBT as byte vectors */ +s48_value scsh_enter_DBT_as_bytevector(DBT* dt) +{ + int i; + s48_value res = S48_FALSE; + S48_DECLARE_GC_PROTECT(1); + S48_GC_PROTECT_1(res); + + res = s48_make_byte_vector(dt->size, 0); + i = 0; + + for (i = 0; i < dt->size; i++) + S48_BYTE_VECTOR_SET(res, i, ((char*)(dt->data))[i]); + + S48_GC_UNPROTECT(); + return res; +} + +void scsh_extract_bytevector_as_DBT(s48_value bytevector, DBT* dt) +{ + S48_DECLARE_GC_PROTECT(1); + + S48_GC_PROTECT_1(bytevector); + dt->data = s48_extract_byte_vector(bytevector); + dt->size = S48_BYTE_VECTOR_LENGTH(bytevector); + S48_GC_UNPROTECT(); +} + +/* DBT operations */ + +/* Put key and data DBT's in DB */ +s48_value scsh_bdb_put(s48_value db, s48_value skey, s48_value sdata, + s48_value stxnid, s48_value sflags) +{ + int res; + DB *dbp; + DB_TXN *txnid; + DBT key, data; + u_int32_t flags; + S48_DECLARE_GC_PROTECT(5); + + S48_GC_PROTECT_5(db, skey, sdata, stxnid, sflags); + + dbp = scsh_extract_db(db); + txnid = EXTRACT_OPTIONAL_TXNID(stxnid); + flags = s48_extract_integer(sflags); + + scsh_extract_bytevector_as_DBT(skey, &key); + scsh_extract_bytevector_as_DBT(sdata, &data); + S48_GC_UNPROTECT(); + + res = dbp->put(dbp, txnid, &key, &data, flags); + CHECK_BDB_RESULT_CODE(res); + return scsh_enter_DBT_as_bytevector(&key); +} + +/* Get DBT to corresponding key */ +s48_value scsh_bdb_get(s48_value handle, s48_value skey, + s48_value stxnid, s48_value sflags) +{ + int res; + DB *dbp; + u_int32_t flags; + DB_TXN *txnid; + DBT key, data; + + S48_DECLARE_GC_PROTECT(4); + S48_GC_PROTECT_4(handle, skey, stxnid, sflags); + + dbp = scsh_extract_db(handle); + flags = s48_extract_integer(sflags); + txnid = EXTRACT_OPTIONAL_TXNID(stxnid); + scsh_extract_bytevector_as_DBT(skey, &key); + S48_GC_UNPROTECT(); + + res = dbp->get(dbp, txnid, &key, &data, flags); + CHECK_BDB_RESULT_CODE(res); + return scsh_enter_DBT_as_bytevector(&data); +} + +/* Delete DBT to corresponding key */ +s48_value scsh_bdb_del(s48_value handle, s48_value skey, + s48_value stxnid, s48_value sflags) +{ + int res; + DB* dbp; + DB_TXN *txnid; + DBT key; + u_int32_t flags; + + S48_DECLARE_GC_PROTECT(4); + S48_GC_PROTECT_4(handle, skey, stxnid, sflags); + + dbp = scsh_extract_db(handle); + flags = s48_extract_integer(sflags); + txnid = EXTRACT_OPTIONAL_TXNID(stxnid); + scsh_extract_bytevector_as_DBT(skey, &key); + + S48_GC_UNPROTECT(); + res = dbp->del(dbp, txnid, &key, flags); + CHECK_BDB_RESULT_CODE(res); + return S48_TRUE; +} + +s48_value scsh_bdb_create_cursor(s48_value handle, s48_value stxnid, + s48_value sflags) +{ + int res; + DB* dbp; + DBC* dbcp; + DB_TXN *txnid; + u_int32_t flags; + s48_value ret = S48_FALSE; + + S48_DECLARE_GC_PROTECT(4); + S48_GC_PROTECT_4(handle, stxnid, sflags, ret); + + dbp = scsh_extract_db(handle); + flags = s48_extract_integer(sflags); + txnid = EXTRACT_OPTIONAL_TXNID(stxnid); + + S48_GC_UNPROTECT(); + res = dbp->cursor(dbp,txnid, &dbcp, flags); + CHECK_BDB_RESULT_CODE(res); + return scsh_enter_cursor(dbcp); +} + +/* retrieve values from cursor */ +s48_value scsh_bdb_cursor_cget(s48_value dbc, s48_value sflags) +{ + int res; + DBC* dbcp; + u_int32_t flags; + DBT *key, *data; + + S48_DECLARE_GC_PROTECT(2); + S48_GC_PROTECT_2(dbc, sflags); + + dbcp = scsh_extract_cursor(dbc); + flags = s48_extract_integer(sflags); + S48_GC_UNPROTECT(); + + res = dbcp->c_get(dbcp, key, data, flags); + CHECK_BDB_RESULT_CODE(res); + return scsh_enter_DBT_as_bytevector(data); +} + +s48_value scsh_bdb_txn_begin (s48_value handle, s48_value sparent, + s48_value sflags) +{ + int res; + DB_ENV* env; + DBC* dbcp; + DB_TXN* parent, *txnid; + u_int32_t flags; + s48_value ret = S48_FALSE; + //parent = NULL; // only for nested transactions + + S48_DECLARE_GC_PROTECT(3); + S48_GC_PROTECT_3(handle, sflags, ret); + + env = scsh_extract_env(handle); + flags = s48_extract_integer(sflags); + S48_GC_UNPROTECT(); + + res = env->txn_begin(env, NULL, &txnid, flags); + CHECK_BDB_RESULT_CODE(res); + return scsh_enter_txnid(txnid); +} + +s48_value scsh_bdb_txn_abort(s48_value stxnid) +{ + int res; + DB_TXN *txnid; + s48_value ret = S48_FALSE; + + S48_DECLARE_GC_PROTECT(1); + S48_GC_PROTECT_1(stxnid); + + txnid = EXTRACT_OPTIONAL_TXNID(stxnid); + S48_GC_UNPROTECT(); + + res = txnid->abort(txnid); + CHECK_BDB_RESULT_CODE(res); + return S48_TRUE; +} + +s48_value scsh_bdb_txn_commit(s48_value stxnid, s48_value sflags) +{ + int res; + DB_TXN *txnid; + s48_value ret = S48_FALSE; + u_int32_t flags; + S48_DECLARE_GC_PROTECT(2); + S48_GC_PROTECT_2(stxnid, sflags); + flags = s48_extract_integer(sflags); + txnid = EXTRACT_OPTIONAL_TXNID(stxnid); + S48_GC_UNPROTECT(); + + res = txnid->commit(txnid, flags); + CHECK_BDB_RESULT_CODE(res); + return S48_TRUE; +} + +/* initialize bindings */ +void scsh_init_bdb_bindings(void) +{ + /* records */ + S48_GC_PROTECT_GLOBAL(bdb_db_record_type); + bdb_db_record_type = s48_get_imported_binding("bdb-db"); + + S48_GC_PROTECT_GLOBAL(bdb_env_record_type); + bdb_env_record_type = s48_get_imported_binding("bdb-env"); + + S48_GC_PROTECT_GLOBAL(bdb_mpoolfile_record_type); + bdb_mpoolfile_record_type = s48_get_imported_binding("bdb-mpoolfile"); + + S48_GC_PROTECT_GLOBAL(bdb_txn_record_type); + bdb_txn_record_type = s48_get_imported_binding("bdb-txn"); + + S48_GC_PROTECT_GLOBAL(bdb_dbc_record_type); + bdb_dbc_record_type = s48_get_imported_binding("bdb-dbc"); + + /* flag constants */ + S48_GC_PROTECT_GLOBAL(scheme_DB_RPCCLIENT); + scheme_DB_RPCCLIENT = s48_enter_integer(DB_RPCCLIENT); + s48_define_exported_binding("scheme_DB_RPCCLIENT",scheme_DB_RPCCLIENT); + + S48_GC_PROTECT_GLOBAL(scheme_DB_INIT_LOCK); + scheme_DB_INIT_LOCK = s48_enter_integer(DB_INIT_LOCK); + s48_define_exported_binding("scheme_DB_INIT_LOCK",scheme_DB_INIT_LOCK); + + S48_GC_PROTECT_GLOBAL(scheme_DB_JOINENV); + scheme_DB_JOINENV = s48_enter_integer(DB_JOINENV); + s48_define_exported_binding("scheme_DB_JOINENV",scheme_DB_JOINENV); + + S48_GC_PROTECT_GLOBAL(scheme_DB_INIT_MPOOL); + scheme_DB_INIT_MPOOL = s48_enter_integer(DB_INIT_MPOOL); + s48_define_exported_binding("scheme_DB_INIT_MPOOL",scheme_DB_INIT_MPOOL); + + S48_GC_PROTECT_GLOBAL(scheme_DB_INIT_LOG); + scheme_DB_INIT_LOG = s48_enter_integer(DB_INIT_LOG); + s48_define_exported_binding("scheme_DB_INIT_LOG",scheme_DB_INIT_LOG); + + S48_GC_PROTECT_GLOBAL(scheme_DB_INIT_REP); + scheme_DB_INIT_REP = s48_enter_integer(DB_INIT_REP); + s48_define_exported_binding("scheme_DB_INIT_REP",scheme_DB_INIT_REP); + + S48_GC_PROTECT_GLOBAL(scheme_DB_INIT_TXN); + scheme_DB_INIT_TXN = s48_enter_integer(DB_INIT_TXN); + s48_define_exported_binding("scheme_DB_INIT_TXN",scheme_DB_INIT_TXN); + + S48_GC_PROTECT_GLOBAL(scheme_DB_RECOVER); + scheme_DB_RECOVER = s48_enter_integer(DB_RECOVER); + s48_define_exported_binding("scheme_DB_RECOVER",scheme_DB_RECOVER); + + S48_GC_PROTECT_GLOBAL(scheme_DB_RECOVER_FATAL); + scheme_DB_RECOVER_FATAL = s48_enter_integer(DB_RECOVER_FATAL); + s48_define_exported_binding("scheme_DB_RECOVER_FATAL",scheme_DB_RECOVER_FATAL); + + S48_GC_PROTECT_GLOBAL(scheme_DB_USE_ENVIRON); + scheme_DB_USE_ENVIRON = s48_enter_integer(DB_USE_ENVIRON); + s48_define_exported_binding("scheme_DB_USE_ENVIRON",scheme_DB_USE_ENVIRON); + + S48_GC_PROTECT_GLOBAL(scheme_DB_USE_ENVIRON_ROOT); + scheme_DB_USE_ENVIRON_ROOT = s48_enter_integer(DB_USE_ENVIRON_ROOT); + s48_define_exported_binding("scheme_DB_USE_ENVIRON_ROOT",scheme_DB_USE_ENVIRON_ROOT); + + S48_GC_PROTECT_GLOBAL(scheme_DB_CREATE); + scheme_DB_CREATE = s48_enter_integer(DB_CREATE); + s48_define_exported_binding("scheme_DB_CREATE",scheme_DB_CREATE); + + S48_GC_PROTECT_GLOBAL(scheme_DB_LOCKDOWN); + scheme_DB_LOCKDOWN = s48_enter_integer(DB_LOCKDOWN); + s48_define_exported_binding("scheme_DB_LOCKDOWN",scheme_DB_LOCKDOWN); + + S48_GC_PROTECT_GLOBAL(scheme_DB_PRIVATE); + scheme_DB_PRIVATE = s48_enter_integer(DB_PRIVATE); + s48_define_exported_binding("scheme_DB_PRIVATE",scheme_DB_PRIVATE); + + S48_GC_PROTECT_GLOBAL(scheme_DB_SYSTEM_MEM); + scheme_DB_SYSTEM_MEM = s48_enter_integer(DB_SYSTEM_MEM); + s48_define_exported_binding("scheme_DB_SYSTEM_MEM",scheme_DB_SYSTEM_MEM); + + S48_GC_PROTECT_GLOBAL(scheme_DB_THREAD); + scheme_DB_THREAD = s48_enter_integer(DB_THREAD); + s48_define_exported_binding("scheme_DB_THREAD",scheme_DB_THREAD); + + S48_GC_PROTECT_GLOBAL(scheme_DB_AUTO_COMMIT); + scheme_DB_AUTO_COMMIT = s48_enter_integer(DB_AUTO_COMMIT); + s48_define_exported_binding("scheme_DB_AUTO_COMMIT",scheme_DB_AUTO_COMMIT); + + S48_GC_PROTECT_GLOBAL(scheme_DB_DIRTY_READ); + scheme_DB_DIRTY_READ = s48_enter_integer(DB_DIRTY_READ); + s48_define_exported_binding("scheme_DB_DIRTY_READ",scheme_DB_DIRTY_READ); + + S48_GC_PROTECT_GLOBAL(scheme_DB_EXCL); + scheme_DB_EXCL = s48_enter_integer(DB_EXCL); + s48_define_exported_binding("scheme_DB_EXCL",scheme_DB_EXCL); + + S48_GC_PROTECT_GLOBAL(scheme_DB_NOMMAP); + scheme_DB_NOMMAP = s48_enter_integer(DB_NOMMAP); + s48_define_exported_binding("scheme_DB_NOMMAP",scheme_DB_NOMMAP); + + S48_GC_PROTECT_GLOBAL(scheme_DB_RDONLY); + scheme_DB_RDONLY = s48_enter_integer(DB_RDONLY); + s48_define_exported_binding("scheme_DB_RDONLY",scheme_DB_RDONLY); + + S48_GC_PROTECT_GLOBAL(scheme_DB_SYSTEM_MEM); + scheme_DB_SYSTEM_MEM = s48_enter_integer(DB_SYSTEM_MEM); + s48_define_exported_binding("scheme_DB_SYSTEM_MEM",scheme_DB_SYSTEM_MEM); + + S48_GC_PROTECT_GLOBAL(scheme_DB_TRUNCATE); + scheme_DB_TRUNCATE = s48_enter_integer(DB_TRUNCATE); + s48_define_exported_binding("scheme_DB_TRUNCATE",scheme_DB_TRUNCATE); + + S48_GC_PROTECT_GLOBAL(scheme_DB_NOSYNC); + scheme_DB_NOSYNC = s48_enter_integer(DB_NOSYNC); + s48_define_exported_binding("scheme_DB_NOSYNC",scheme_DB_NOSYNC); + + S48_GC_PROTECT_GLOBAL(scheme_DB_CONSUME); + scheme_DB_CONSUME = s48_enter_integer(DB_CONSUME); + s48_define_exported_binding("scheme_DB_CONSUME",scheme_DB_CONSUME); + + S48_GC_PROTECT_GLOBAL(scheme_DB_CONSUME_WAIT); + scheme_DB_CONSUME_WAIT = s48_enter_integer(DB_CONSUME_WAIT); + s48_define_exported_binding("scheme_DB_CONSUME_WAIT",scheme_DB_CONSUME_WAIT); + + S48_GC_PROTECT_GLOBAL(scheme_DB_GET_BOTH); + scheme_DB_GET_BOTH = s48_enter_integer(DB_GET_BOTH); + s48_define_exported_binding("scheme_DB_GET_BOTH",scheme_DB_GET_BOTH); + + S48_GC_PROTECT_GLOBAL(scheme_DB_RMW); + scheme_DB_RMW = s48_enter_integer(DB_RMW); + s48_define_exported_binding("scheme_DB_RMW",scheme_DB_RMW); + + S48_GC_PROTECT_GLOBAL(scheme_DB_MULTIPLE); + scheme_DB_MULTIPLE = s48_enter_integer(DB_MULTIPLE); + s48_define_exported_binding("scheme_DB_MULTIPLE",scheme_DB_MULTIPLE); + + S48_GC_PROTECT_GLOBAL(scheme_DB_SET_RECNO); + scheme_DB_SET_RECNO = s48_enter_integer(DB_SET_RECNO); + s48_define_exported_binding("scheme_DB_SET_RECNO",scheme_DB_SET_RECNO); + + S48_GC_PROTECT_GLOBAL(scheme_DB_APPEND); + scheme_DB_APPEND = s48_enter_integer(DB_APPEND); + s48_define_exported_binding("scheme_DB_APPEND",scheme_DB_APPEND); + + S48_GC_PROTECT_GLOBAL(scheme_DB_NODUPDATA); + scheme_DB_NODUPDATA = s48_enter_integer(DB_NODUPDATA); + s48_define_exported_binding("scheme_DB_NODUPDATA",scheme_DB_NODUPDATA); + + S48_GC_PROTECT_GLOBAL(scheme_DB_NOOVERWRITE); + scheme_DB_NOOVERWRITE = s48_enter_integer(DB_NOOVERWRITE); + s48_define_exported_binding("scheme_DB_NOOVERWRITE",scheme_DB_NOOVERWRITE); + + S48_GC_PROTECT_GLOBAL(scheme_DB_CURRENT); + scheme_DB_CURRENT = s48_enter_integer(DB_CURRENT); + s48_define_exported_binding("scheme_DB_CURRENT",scheme_DB_CURRENT); + + S48_GC_PROTECT_GLOBAL(scheme_DB_FIRST); + scheme_DB_FIRST = s48_enter_integer(DB_FIRST); + s48_define_exported_binding("scheme_DB_FIRST",scheme_DB_FIRST); + + S48_GC_PROTECT_GLOBAL(scheme_DB_WRITECURSOR); + scheme_DB_WRITECURSOR = s48_enter_integer(DB_WRITECURSOR); + s48_define_exported_binding("scheme_DB_WRITECURSOR",scheme_DB_WRITECURSOR); + + S48_GC_PROTECT_GLOBAL(scheme_DB_GET_BOTH_RANGE); + scheme_DB_GET_BOTH_RANGE = s48_enter_integer(DB_GET_BOTH_RANGE); + s48_define_exported_binding("scheme_DB_GET_BOTH_RANGE",scheme_DB_GET_BOTH_RANGE); + + S48_GC_PROTECT_GLOBAL(scheme_DB_GET_RECNO); + scheme_DB_GET_RECNO = s48_enter_integer(DB_GET_RECNO); + s48_define_exported_binding("scheme_DB_GET_RECNO",scheme_DB_GET_RECNO); + + S48_GC_PROTECT_GLOBAL(scheme_DB_JOIN_ITEM); + scheme_DB_JOIN_ITEM = s48_enter_integer(DB_JOIN_ITEM); + s48_define_exported_binding("scheme_DB_JOIN_ITEM",scheme_DB_JOIN_ITEM); + + S48_GC_PROTECT_GLOBAL(scheme_DB_LAST); + scheme_DB_LAST = s48_enter_integer(DB_LAST); + s48_define_exported_binding("scheme_DB_LAST",scheme_DB_LAST); + + S48_GC_PROTECT_GLOBAL(scheme_DB_NEXT); + scheme_DB_NEXT = s48_enter_integer(DB_NEXT); + s48_define_exported_binding("scheme_DB_NEXT",scheme_DB_NEXT); + + S48_GC_PROTECT_GLOBAL(scheme_DB_NEXT_DUP); + scheme_DB_NEXT_DUP = s48_enter_integer(DB_NEXT_DUP); + s48_define_exported_binding("scheme_DB_NEXT_DUP",scheme_DB_NEXT_DUP); + + S48_GC_PROTECT_GLOBAL(scheme_DB_NEXT_NODUP); + scheme_DB_NEXT_NODUP = s48_enter_integer(DB_NEXT_NODUP); + s48_define_exported_binding("scheme_DB_NEXT_NODUP",scheme_DB_NEXT_NODUP); + + S48_GC_PROTECT_GLOBAL(scheme_DB_PREV); + scheme_DB_PREV = s48_enter_integer(DB_PREV); + s48_define_exported_binding("scheme_DB_PREV",scheme_DB_PREV); + + S48_GC_PROTECT_GLOBAL(scheme_DB_SET); + scheme_DB_SET = s48_enter_integer(DB_SET); + s48_define_exported_binding("scheme_DB_SET",scheme_DB_SET); + + S48_GC_PROTECT_GLOBAL(scheme_DB_SET_RANGE); + scheme_DB_SET_RANGE = s48_enter_integer(DB_SET_RANGE); + s48_define_exported_binding("scheme_DB_SET_RANGE",scheme_DB_SET_RANGE); + + S48_GC_PROTECT_GLOBAL(scheme_DB_MULTIPLE_KEY); + scheme_DB_MULTIPLE_KEY = s48_enter_integer(DB_MULTIPLE_KEY); + s48_define_exported_binding("scheme_DB_MULTIPLE_KEY",scheme_DB_MULTIPLE_KEY); + + S48_GC_PROTECT_GLOBAL(scheme_DB_TXN_NOSYNC); + scheme_DB_TXN_NOSYNC = s48_enter_integer(DB_TXN_NOSYNC); + s48_define_exported_binding("scheme_DB_TXN_NOSYNC",scheme_DB_TXN_NOSYNC); + + S48_GC_PROTECT_GLOBAL(scheme_DB_TXN_NOWAIT); + scheme_DB_TXN_NOWAIT = s48_enter_integer(DB_TXN_NOWAIT); + s48_define_exported_binding("scheme_DB_TXN_NOWAIT",scheme_DB_TXN_NOWAIT); + + S48_GC_PROTECT_GLOBAL(scheme_DB_TXN_SYNC); + scheme_DB_TXN_SYNC = s48_enter_integer(DB_TXN_SYNC); + s48_define_exported_binding("scheme_DB_TXN_SYNC",scheme_DB_TXN_SYNC); + + S48_GC_PROTECT_GLOBAL(scheme_DB_BTREE); + scheme_DB_BTREE = s48_enter_integer(DB_BTREE); + s48_define_exported_binding("scheme_DB_BTREE",scheme_DB_BTREE); + + S48_GC_PROTECT_GLOBAL(scheme_DB_HASH); + scheme_DB_HASH = s48_enter_integer(DB_HASH); + s48_define_exported_binding("scheme_DB_HASH",scheme_DB_HASH); + + S48_GC_PROTECT_GLOBAL(scheme_DB_QUEUE); + scheme_DB_QUEUE = s48_enter_integer(DB_QUEUE); + s48_define_exported_binding("scheme_DB_QUEUE",scheme_DB_QUEUE); + + S48_GC_PROTECT_GLOBAL(scheme_DB_RECNO); + scheme_DB_RECNO = s48_enter_integer(DB_RECNO); + s48_define_exported_binding("scheme_DB_RECNO",scheme_DB_RECNO); + + S48_GC_PROTECT_GLOBAL(scheme_DB_UNKNOWN); + scheme_DB_UNKNOWN = s48_enter_integer(DB_UNKNOWN); + s48_define_exported_binding("scheme_DB_UNKNOWN",scheme_DB_UNKNOWN); + + /* export functions to scheme */ + S48_EXPORT_FUNCTION(scsh_bdb_create); + S48_EXPORT_FUNCTION(scsh_bdb_open); + S48_EXPORT_FUNCTION(scsh_bdb_close); + S48_EXPORT_FUNCTION(scsh_bdb_put); + S48_EXPORT_FUNCTION(scsh_bdb_get); + S48_EXPORT_FUNCTION(scsh_bdb_del); + S48_EXPORT_FUNCTION(scsh_bdb_env_create); + S48_EXPORT_FUNCTION(scsh_bdb_env_open); + S48_EXPORT_FUNCTION(scsh_bdb_env_close); + S48_EXPORT_FUNCTION(scsh_bdb_env_remove); + S48_EXPORT_FUNCTION(scsh_bdb_truncate); + S48_EXPORT_FUNCTION(scsh_bdb_sync); + S48_EXPORT_FUNCTION(scsh_bdb_create_cursor); + S48_EXPORT_FUNCTION(scsh_bdb_cursor_cget); + S48_EXPORT_FUNCTION(scsh_bdb_txn_begin); + S48_EXPORT_FUNCTION(scsh_bdb_txn_abort); + S48_EXPORT_FUNCTION(scsh_bdb_txn_commit); +} diff --git a/c/bdb.h b/c/bdb.h new file mode 100644 index 0000000..2233316 --- /dev/null +++ b/c/bdb.h @@ -0,0 +1,48 @@ +#include +#include +#include +#include + +#include "scheme48.h" +#include "db.h" + +/* record types */ +static s48_value bdb_db_record_type = S48_FALSE; +static s48_value bdb_env_record_type = S48_FALSE; +static s48_value bdb_mpoolfile_record_type = S48_FALSE; +static s48_value bdb_txn_record_type = S48_FALSE; +static s48_value bdb_dbc_record_type = S48_FALSE; + +/* prototypes and macros */ +s48_value scsh_enter_db(DB *h); +#define scsh_extract_db(x) \ + ((DB *) s48_extract_integer(S48_RECORD_REF(x, 0))) + +s48_value scsh_enter_txnid(DB_TXN *txnid); +#define scsh_extract_txnid(x) \ + ((DB_TXN *) s48_extract_integer(S48_RECORD_REF(x, 0))) + +s48_value scsh_enter_cursor(DBC *dbc); +#define scsh_extract_cursor(x) \ + ((DBC *) s48_extract_integer(S48_RECORD_REF(x, 0))) + +s48_value scsh_enter_dbenv(DB_ENV *h); +#define scsh_extract_dbenv(x) \ + ((DB_ENV *) s48_extract_integer(S48_RECORD_REF(x, 0))) + +#define CHECK_BDB_RESULT_CODE(res) \ + do { \ + if (res < 0) \ + s48_raise_os_error(res); \ + if (res > 0) \ + return s48_enter_integer(res); \ + } while (0); + +#define EXTRACT_OPTIONAL_STRING(string) \ + ((string == S48_FALSE) ? NULL : s48_extract_string(string)) + +#define EXTRACT_OPTIONAL_TXNID(txnid) \ + ((txnid == S48_FALSE) ? NULL : scsh_extract_txnid(txnid)) + +#define EXTRACT_OPTIONAL_ENV(env) \ + ((env == S48_FALSE) ? NULL : scsh_extract_dbenv(env)) diff --git a/configure.in b/configure.in new file mode 100644 index 0000000..90f5298 --- /dev/null +++ b/configure.in @@ -0,0 +1,39 @@ +AC_INIT(c/bdb.c) +AM_INIT_AUTOMAKE(scsh-bdb, 0.1) +AM_CONFIG_HEADER(c/config.h) + +AC_ENABLE_SHARED +AM_PROG_LIBTOOL + +AC_PROG_CC +AC_STDC_HEADERS + +dnl scsh include path +AC_ARG_WITH(scsh-includes, + AC_HELP_STRING([--with-scsh-includes=DIR], + [scsh include files are in DIR [default is /usr/local/include]]), + scsh_includes=$withval, + scsh_includes=/usr/local/include) +AC_SUBST(CFLAGS, "$CFLAGS -I${scsh_includes}") +AC_SUBST(CPPFLAGS, "$CPPFLAGS -I${scsh_includes}") + +dnl Berkeley DB prefix +AC_ARG_WITH(bdb-prefix, + AC_HELP_STRING([--with-bdb-prefix=DIR], + [Berkeley DB library and include have prefix DIR [default is /usr/local]]), + [bdb_lib=$withval/lib bdb_include=$withval/include], + [bdb_lib=/usr/local/lib bdb_include=/usr/local/include]) +AC_SUBST(LDFLAGS, "$LDFLAGS -L${bdb_lib} -ldb-4") +AC_SUBST(CFLAGS, "$CFLAGS -I${bdb_include}") +AC_SUBST(CPPFLAGS, "$CPPFLAGS -I${bdb_include}") + +schemedir='${prefix}'"/scheme" +libdir='${prefix}'"/lib" +libsysdir='${prefix}' + +AC_SUBST(libdir) +AC_SUBST(libsysdir) +AC_SUBST(schemedir) +AC_SUBST(CC) +AC_OUTPUT([Makefile c/Makefile]) + diff --git a/pkg-def.scm b/pkg-def.scm new file mode 100644 index 0000000..b2abdd5 --- /dev/null +++ b/pkg-def.scm @@ -0,0 +1,74 @@ +(define-package "bdb" (0 1 0) + ((install-lib-version (1 0)) + (options (bdb-prefix "Uses Berkeley DB library with prefix" "" #t #f #f))) + + (define (display-bold text) + (display "\033[1m") + (display text) + (display "\033[m")) + + (newline) + (display-bold "Configuring, compiling and installing C-stubs") + (newline) + + (let* ((scsh-includes (include-dir)) + (build-host (get-option-value 'build)) + (prefix (string-append (get-directory 'lib #f) "/" build-host)) + (configure (append + (list "./configure" + (string-append "--prefix=" prefix) + (string-append "--with-scsh-includes=" scsh-includes) + (string-append "--enable-static=no") + (string-append "--build=" build-host)) + (cond ((get-option-value 'bdb-prefix) + => (lambda (prefix) + (list + (string-append "--with-bdb-prefix=" prefix)))) + (else '())))) + (make `(make install + ,(string-append "DESTDIR=" (get-option-value 'dest-dir))))) + (if (get-option-value 'dry-run) + (begin + (display configure) (newline) + (display make) (newline)) + (if (not (and (zero? (run ,configure)) + (zero? (run ,make)))) + (exit)))) + + (newline) + (display-bold "Creating load.scm") + (newline) + + (let ((schemedir (get-directory 'scheme #f)) + (libdir (get-directory 'lib #f))) + (write-to-load-script + `((user) + (load-package 'dynamic-externals) + (open 'dynamic-externals) + (open 'external-calls) + (open 'configure) + (open 'signals) + ,@(map (lambda (x) `(run ',x)) tmpl-libtool-la-reader) + (run '(let* ((lib-dir (string-append ,libdir "/" (host))) + (la-file-name (string-append lib-dir "/libscshbdb.la")) + (initializer-name "scsh_init_bdb_bindings")) + (let ((la-alist (read-libtool-la la-file-name))) + (cond + ((assoc 'dlname la-alist) + => (lambda (p) + (let ((module-file (string-append lib-dir "/" (cdr p)))) + (dynamic-load module-file) + (call-external (get-external initializer-name))))) + (else + (error "Could not figure out libscshbdb's name" la-file-name)))))) + (config) + (load ,(string-append schemedir "/packages.scm")) + (user)))) + + (newline) + (display-bold "Installing Scheme files") + (newline) + + (install-directory-contents "scheme" 'scheme) + ) + diff --git a/scheme/bdb.scm b/scheme/bdb.scm new file mode 100644 index 0000000..e85e9f5 --- /dev/null +++ b/scheme/bdb.scm @@ -0,0 +1,603 @@ +;;; macro +(define-syntax lookup-shared-value + (syntax-rules () + ((lookup-shared-value %s) + (shared-binding-ref + (lookup-imported-binding %s))))) + +;;; weak lists +(define (cons-weak obj list) + (cons (make-weak-pointer obj) list)) + +(define (filter-collected list) + (filter (lambda (weak-pointer) + (not (weak-pointer-ref weak-pointer))) + list)) + +;;; fluids +(define $current-env (make-fluid #f)) +(define $current-db (make-fluid #f)) +(define $current-transaction-id (make-fluid #f)) + +(define (current-env) + (fluid $current-env)) + +(define (current-db) + (fluid $current-db)) + +(define (current-transaction-id) + (fluid $current-transaction-id)) + +(define (with-env db-env thunk) + (let-fluid $current-env db-env thunk)) + +(define (with-db db thunk) + (let-fluid $current-db db thunk)) + +(define (with-transaction options proc) + (let-fluid + $current-transaction-id + (bdb-begin-transaction options) + (lambda () + (proc (lambda () + (bdb-abort-transaction (current-transaction-id)))) + (bdb-commit-transaction (current-transaction-id))))) + +;; constants +(define-finite-type bdb-flags :bdb-flags + (id) + bdb-flags-object? + bdb-flags-elements + bdb-flags-name + bdb-flags-index + (id bdb-flags-id) + ((default 0) + (rpc-client (lookup-shared-value "scheme_DB_RPCCLIENT")) + (join-env (lookup-shared-value "scheme_DB_JOINENV")) + (init-lock (lookup-shared-value "scheme_DB_INIT_LOCK")) + (init-log (lookup-shared-value "scheme_DB_INIT_LOG")) + (init-mpool (lookup-shared-value "scheme_DB_INIT_MPOOL")) + (init-replication (lookup-shared-value "scheme_DB_INIT_REP")) + (init-transactions (lookup-shared-value "scheme_DB_INIT_TXN")) + (run-recover (lookup-shared-value "scheme_DB_RECOVER")) + (recover-fatal (lookup-shared-value "scheme_DB_RECOVER_FATAL")) + (use-environ (lookup-shared-value "scheme_DB_USE_ENVIRON")) + (use-environ-root (lookup-shared-value "scheme_DB_USE_ENVIRON_ROOT")) + (create (lookup-shared-value "scheme_DB_CREATE")) + (lockdown (lookup-shared-value "scheme_DB_LOCKDOWN")) + (private (lookup-shared-value "scheme_DB_PRIVATE")) + (system-mem (lookup-shared-value "scheme_DB_SYSTEM_MEM")) + (thread (lookup-shared-value "scheme_DB_THREAD")) + (force (lookup-shared-value "scheme_DB_FORCE")) + (xa-create (lookup-shared-value "scheme_DB_XA_CREATE")) + (auto-commit (lookup-shared-value "scheme_DB_AUTO_COMMIT")) + (dirty-read (lookup-shared-value "scheme_DB_DIRTY_READ")) + (excl (lookup-shared-value "scheme_DB_EXCL")) + (nommap (lookup-shared-value "scheme_DB_NOMMAP")) + (rdonly (lookup-shared-value "scheme_DB_RDONLY")) + (thread (lookup-shared-value "scheme_DB_SYSTEM_MEM")) + (truncate (lookup-shared-value "scheme_DB_TRUNCATE")) + (nosync (lookup-shared-value "scheme_DB_NOSYNC")) + (consume (lookup-shared-value "scheme_DB_CONSUME")) + (consume-wait (lookup-shared-value "scheme_DB_CONSUME_WAIT")) + (get-both (lookup-shared-value "scheme_DB_GET_BOTH")) + (multiple (lookup-shared-value "scheme_DB_MULTIPLE")) + (rmw (lookup-shared-value "scheme_DB_RMW")) + (set-recno (lookup-shared-value "scheme_DB_SET_RECNO")) + (append (lookup-shared-value "scheme_DB_APPEND")) + (nodupdata (lookup-shared-value "scheme_DB_NODUPDATA")) + (nooverwrite (lookup-shared-value "scheme_DB_NOOVERWRITE")) + (current (lookup-shared-value "scheme_DB_CURRENT")) + (first (lookup-shared-value "scheme_DB_FIRST")) + (get-both (lookup-shared-value "scheme_DB_GET_BOTH")) + (writecursor (lookup-shared-value "scheme_DB_WRITECURSOR")) + (get-both-range (lookup-shared-value "scheme_DB_GET_BOTH_RANGE")) + (get-recno (lookup-shared-value "scheme_DB_GET_RECNO")) + (join-item (lookup-shared-value "scheme_DB_JOIN_ITEM")) + (last (lookup-shared-value "scheme_DB_LAST")) + (next (lookup-shared-value "scheme_DB_NEXT")) + (next-dup (lookup-shared-value "scheme_DB_NEXT_DUP")) + (next-nodup (lookup-shared-value "scheme_DB_NEXT_NODUP")) + (prev (lookup-shared-value "scheme_DB_PREV")) + (prev-nodup (lookup-shared-value "scheme_DB_PREV_NODUP")) + (set (lookup-shared-value "scheme_DB_SET")) + (set-range (lookup-shared-value "scheme_DB_SET_RANGE")) + (multiple-key (lookup-shared-value "scheme_DB_MULTIPLE_KEY")) + (txn-nosync (lookup-shared-value "scheme_DB_TXN_NOSYNC")) + (txn-nowait (lookup-shared-value "scheme_DB_TXN_NOWAIT")) + (txn-sync (lookup-shared-value "scheme_DB_TXN_SYNC")))) + +(define (fold-flags valid unit given) + (fold-right + (lambda (f flag) + (if (member f valid) + (bitwise-ior (bdb-flags-id f) flag) + (raise (condition + (&bdb-invalid-flag (value given)))))) + (bdb-flags-id unit) + (if (list? given) given (list given)))) + +(define (flag-one-of valid given) + (cond + ((null? given) + (bdb-flags-id (bdb-flags default))) + ((member given valid) + => (lambda (l) + (bdb-flags-id (car l)))) + (else + (raise + (condition + (&bdb-invalid-flag (value given))))))) + +(define-finite-type database-type :database-type + (id) + database-type-object? + database-type-elements + database-type-name + database-type-index + (id database-type-id) + ((binary-tree (lookup-shared-value "scheme_DB_BTREE")) + (hash (lookup-shared-value "scheme_DB_HASH")) + (queue (lookup-shared-value "scheme_DB_QUEUE")) + (recno (lookup-shared-value "scheme_DB_RECNO")) + (unknown (lookup-shared-value "scheme_DB_UNKNOWN")))) + +;;; define error conditions +;;; with subconditions +(define-condition-type &bdb-error &condition + bdb-error?) + +;;; without subconditions + +;; DB_LOCK_DEADLOCK +(define-condition-type &bdb-lock-deadlock &bdb-error + bdb-lock-deadlock?) + +;;DB_LOCK_NOTGRANTED +(define-condition-type &bdb-lock-not-granted &bdb-error + bdb-lock-not-granted?) + +;; DB_OLD_VERSION +(define-condition-type &bdb-old-db-version &bdb-error + bdb-old-db-version?) + +;; DB_REP_HANDLE_DEAD +(define-condition-type &bdb-db-handle-dead &bdb-error + bdb-db-handle-dead?) + +;; DB_SECONDARY_BAD +(define-condition-type &bdb-secondary-index-bad &bdb-error + bdb-secondary-index-bad?) + +(define-condition-type &bdb-invalid-flag &bdb-error + bdb-invalid-flag?) + +(define raise-bdb-condition + (let ((alist + `((,-30995 ,&bdb-lock-deadlock) + (,-30994 ,&bdb-lock-not-granted) + (,-30989 ,&bdb-old-db-version) + (,-30986 ,&bdb-db-handle-dead) + (,-30977 , &bdb-secondary-index-bad)))) + (lambda (return-object) + (cond + ((assoc return-object alist) + => (lambda (p) + (let ((the-condition (cadr p))) + (raise (condition (the-condition)))))) + (else + (raise + (condition (&bdb-error + (code return-object))))))))) + + +;;; define bdb records +;;; DB handle : DB +(define-record-type bdb-db :bdb-db + (make-bdb-db c-pointer) + bdb-db? + (c-pointer bdb-db-c-pointer)) + +(define-exported-binding "bdb-db" :bdb-db) + +;;; DB environement handle : DB_ENV +(define-record-type bdb-env :bdb-env + (make-bdb-env c-pointer weak-list) + bdb-env? + (c-pointer bdb-env-c-pointer) + (weak-list bdb-env-weak-list set-bdb-env-weak-list!)) + +(define-exported-binding "bdb-env" :bdb-env) + +(define (bdb-env-weak-list-add! session thing) + (set-bdb-env-weak-list! + session (cons-weak thing (bdb-env-weak-list session)))) + +(define (bdb-env-weak-list-filter! session) + (set-bdb-env-weak-list! + session (filter-collected (bdb-env-weak-list session)))) + +(define (bdb-env-finalizer-free session) + (bdb-env-close session)) + +(define (bdb-env-finalizer session) + (bdb-env-weak-list-filter! session) + (if (null? (bdb-env-weak-list session)) + (add-finalizer! session bdb-env-finalizer-free) + (add-finalizer! session bdb-env-finalizer))) + +;;; DB memory poolfile : DB_MPOOLFILE +(define-record-type bdb-mpoolfile :bdb-mpoolfile + (make-bdb-mpoolfile c-pointer) + bdb-mpoolfile? + (c-pointer bdb-mpoolfile-c-pointer)) + +(define-exported-binding "bdb-mpoolfile" :bdb-mpoolfile) + +;;; DB transaction : DB_TXN +(define-record-type bdb-txn :bdb-txn + (make-bdb-txn c-pointer) + bdb-txn? + (c-pointer bdb-txn-c-pointer)) + +(define-exported-binding "bdb-txn" :bdb-txn) + +;;; DB Cursor : DBC +(define-record-type bdb-dbc :bdb-dbc + (make-bdb-dbc c-pointer) + bdb-dbc? + (c-pointer bdb-dbc-c-pointer)) + +(define-exported-binding "bdb-dbc" :bdb-dbc) + +(import-lambda-definition bdb-env-create-int (flags) + "scsh_bdb_env_create") + +(define bdb-env-create + (let ((valid-flags (list (bdb-flags rpc-client)))) + (lambda args + (let-optionals args + ((flags '())) + (let ((handle + (bdb-env-create-int (flag-one-of valid-flags flags)))) + (if (integer? handle) + (raise-bdb-condition handle) + (begin + (add-finalizer! handle bdb-env-close) + handle))))))) + +(import-lambda-definition + bdb-env-open-int + (env-handle db-home flags mode) + "scsh_bdb_env_open") + +(define bdb-env-open + (let ((valid-flags + (list (bdb-flags join-env) (bdb-flags init-lock) + (bdb-flags init-log) (bdb-flags init-mpool) + (bdb-flags init-replication) (bdb-flags init-transactions) + (bdb-flags run-recover) (bdb-flags recover-fatal)))) + (lambda (env-handle home-dir . args) + (let-optionals args + ((flags '()) + (mode 0)) + (let ((ret-object + (bdb-env-open-int + env-handle home-dir + (fold-flags valid-flags (bdb-flags default) flags) + mode))) + (if (integer? ret-object) + (raise-bdb-condition ret-object) + ret-object)))))) + +(import-lambda-definition + bdb-env-close-int + (env-handle flags) + "scsh_bdb_env_close") + +(define (bdb-env-close env-handle) + (let ((ret-object + (bdb-env-close-int env-handle (bdb-flags default)))) + (if (integer? ret-object) + (raise-bdb-condition ret-object) + ret-object))) + +(import-lambda-definition + bdb-env-remove-int + (db-home flags) + "scsh_bdb_env_remove") + +;;; FIXME +; (define (bdb-env-remove env_handle db_home . args) +; (let-optionals args +; ((flags (bdb-flags DB_DEFAULT))) +; (let* ((ret-object (bdb-env-remove-int env_handle db_home (bdb-flags-id flags)))) +; (if (integer? ret-object) +; (raise-bdb-condition ret-object) +; (begin +; (values ret-object)))))) + +(import-lambda-definition + bdb-create-int + (env-handle flags) + "scsh_bdb_create") + +(define (bdb-create . args) + (let ((valid-flags (list (bdb-flags xa-create)))) + (let-optionals args + ((env (or (current-env) #f)) + (flags '())) + (let ((handle + (bdb-create-int + env + (flag-one-of valid-flags flags)))) + (if (integer? handle) + (raise-bdb-condition handle) + (begin + (add-finalizer! handle bdb-close) + handle)))))) + +(import-lambda-definition + bdb-open-int + (db-handle db-file database txnid type flags mode) + "scsh_bdb_open") + +(define bdb-open + (let ((valid-flags + (list (bdb-flags auto-commit)(bdb-flags create) + (bdb-flags dirty-read) (bdb-flags excl) + (bdb-flags nommap) (bdb-flags rdonly) + (bdb-flags thread) (bdb-flags truncate)))) + (lambda (db-handle db-file . args) + (let-optionals args + ((type (database-type binary-tree)) + (flags '()) + (mode 0) + (database (or (current-db) #f)) + (txn-id (or (current-transaction-id) #f))) + (let ((ret-object + (bdb-open-int db-handle db-file database txn-id + (database-type-id type) + (fold-flags valid-flags (bdb-flags default) flags) + mode))) + (if (integer? ret-object) + (raise-bdb-condition ret-object) + ret-object)))))) + +(import-lambda-definition + bdb-close-int + (db-handle flags) + "scsh_bdb_close") + +(define bdb-close + (let ((valid-flags (list (bdb-flags nosync)))) + (lambda (db-handle . args) + (let-optionals args + ((flags '())) + (let ((ret-object + (bdb-close-int + db-handle + (fold-flags valid-flags (bdb-flags default) flags)))) + (if (integer? ret-object) + (raise-bdb-condition ret-object) + ret-object)))))) + +(import-lambda-definition + bdb-put-int + (db-handle key data txn-id flags) + "scsh_bdb_put") + +(define bdb-put + (let ((valid-flags-0 + (list (bdb-flags append) (bdb-flags nodupdata) + (bdb-flags nooverwrite))) + (valid-flags-1 + (list (bdb-flags auto-commit)))) + (lambda (db-handle key data . args) + (let-optionals args + ((txn-id (or (current-transaction-id) #f)) + (flags-0 #f) + (flags-1 #f)) + (let* ((flags-0 + (if flags-0 + (fold-flags valid-flags-0 (bdb-flags default) flags-0) + (bdb-flags-id (bdb-flags default)))) + (flags-1 + (if flags-1 + (fold-flags valid-flags-1 flags-0 flags-1) + (bdb-flags-id (bdb-flags default)))) + (ret-object + (bdb-put-int db-handle key data txn-id flags-1))) + (if (integer? ret-object) + (raise-bdb-condition ret-object) + ret-object)))))) + +(import-lambda-definition + bdb-get-int + (db-handle key txn-id flags) + "scsh_bdb_get") + +(define bdb-get + (let ((valid-flags-0 + (list (bdb-flags consume) (bdb-flags consume-wait) + (bdb-flags get-both) (bdb-flags set-recno))) + (valid-flags-1 + (list (bdb-flags auto-commit) (bdb-flags multiple) + (bdb-flags rmw)))) + (lambda (db-handle key . args) + (let-optionals args + ((txn-id (or (current-transaction-id) #f)) + (flags-0 #f) + (flags-1 #f)) + (let* ((flags-0 + (if flags-0 + (fold-flags valid-flags-0 (bdb-flags default) flags-0) + (bdb-flags-id (bdb-flags default)))) + (flags-1 + (if flags-1 + (fold-flags valid-flags-1 flags-0 flags-1) + (bdb-flags-id (bdb-flags default)))) + (ret-object + (bdb-get-int db-handle key txn-id flags-1))) + (if (integer? ret-object) + (raise-bdb-condition ret-object) + ret-object)))))) + +(import-lambda-definition + bdb-del-int + (db-handle key txn-id flags) + "scsh_bdb_del") + +(define bdb-del + (let ((valid-flags (list (bdb-flags auto-commit)))) + (lambda (db-handle key . args) + (let-optionals args + ((txn-id (or (current-transaction-id) #f)) + (flags '())) + (let ((ret-object + (bdb-del-int db-handle key txn-id + (flag-one-of valid-flags flags)))) + (if (integer? ret-object) + (raise-bdb-condition ret-object) + ret-object)))))) + +(import-lambda-definition + bdb-truncate-int + (db-home txn-id flags) + "scsh_bdb_truncate") + +(define bdb-truncate + (let ((valid-flags (list (bdb-flags auto-commit)))) + (lambda (db-handle . args) + (let-optionals args + ((txn-id (or (current-transaction-id) #f)) + (flags '())) + (let ((ret-object + (bdb-truncate-int db-handle txn-id + (flag-one-of valid-flags flags)))) + (if (integer? ret-object) + (raise-bdb-condition ret-object) + ret-object)))))) + +(import-lambda-definition + bdb-sync-int + (db-handle) + "scsh_bdb_sync") + +(define bdb-sync + (lambda (db-handle) + (let ((ret-object (bdb-sync-int db-handle))) + (if (integer? ret-object) + (raise-bdb-condition ret-object) + ret-object)))) + +(import-lambda-definition + bdb-create-cursor-int + (db-handle txn-id flags) + "scsh_bdb_create_cursor") + +;;; no need for finalizer since cursor is unitialized after return +; (define (bdb-create-cursor db_handle . args) +; (let-optionals args +; ((txnid #f) +; (flags (bdb-flags DB_DEFAULT))) +; (let* ((ret-object(bdb-create-cursor-int db_handle txnid (bdb-flags-id flags)))) +; (if (integer? ret-object)(raise-bdb-condition ret-object) +; (begin (values ret-object)))))) + +(import-lambda-definition + bdb-cursor-cget-int + (db-handle flags) + "scsh_bdb_cursor_cget") + +; (define (bdb-cursor-cget dbc . args) +; (let-optionals args +; ((flags (bdb-flags DB_DEFAULT))) +; (let* ((ret-object(bdb-cursor-cget-int dbc (bdb-flags-id flags)))) +; (if (integer? ret-object)(raise-bdb-condition ret-object) +; (begin (values ret-object)))))) + +(import-lambda-definition + bdb-txn-begin-int + (env-handle parent flags) + "scsh_bdb_txn_begin") + +(define bdb-begin-transaction + (let ((valid-flags + (list (bdb-flags dirty-read) (bdb-flags txn-nosync) + (bdb-flags txn-nowait) (bdb-flags txn-sync)))) + (lambda (db-env . args) + (let-optionals args + ((parent #f) + (flags #f)) + (let* ((flags + (if flags + (fold-flags valid-flags (bdb-flags default) flags) + (bdb-flags-id (bdb-flags default)))) + (ret-object (bdb-txn-begin-int db-env parent flags))) + (if (integer? ret-object) + (raise-bdb-condition ret-object) + ret-object)))))) + +(import-lambda-definition + bdb-txn-abort-int (txn-id) + "scsh_bdb_txn_abort") + +(define (bdb-abort-transaction txn-id) + (let ((ret-object (bdb-txn-abort-int txn-id))) + (if (integer? ret-object) + (raise-bdb-condition ret-object) + ret-object))) + +(import-lambda-definition + bdb-txn-commit-int + (txn-id flags) + "scsh_bdb_txn_commit") + +(define bdb-commit-transaction + (let ((valid-flags + (list (bdb-flags txn-nosync) (bdb-flags txn-sync)))) + (lambda (txn-id . args) + (let-optionals args + ((flags '())) + (let ((ret-object + (bdb-txn-commit-int txn-id (flag-one-of valid-flags flags)))) + (if (integer? ret-object) + (raise-bdb-condition ret-object) + ret-object)))))) + +(define (string->byte-vector string) + (let* ((length (string-length string)) + (bv (make-byte-vector length 0))) + (let lp ((index (- length 1))) + (if (< index 0) + bv + (begin + (byte-vector-set! + bv index (char->ascii (string-ref string index))) + (lp (- index 1))))))) + +(define (byte-vector->string byte-vector) + (let* ((length (byte-vector-length byte-vector)) + (string (make-string length (ascii->char 0)))) + (let lp ((index (- length 1))) + (if (< index 0) + string + (begin + (string-set! + string index + (ascii->char (byte-vector-ref byte-vector index))) + (lp (- index 1))))))) + +(define (value->byte-vector thing) + (let ((port (make-string-output-port))) + (write thing port) + (string->byte-vector + (string-output-port-output port)))) + +(define (byte-vector->value byte-vector) + (let ((port (make-string-input-port + (byte-vector->string byte-vector)))) + (read port))) + + diff --git a/scheme/packages.scm b/scheme/packages.scm new file mode 100644 index 0000000..a314db1 --- /dev/null +++ b/scheme/packages.scm @@ -0,0 +1,63 @@ +(define-interface berkeley-db-interface + (export + bdb-flags-object? + bdb-flags-elements + bdb-flags-name + (bdb-flags :syntax) + + database-type-object? + database-type-elements + database-type-name + (database-type :syntax) + + &bdb-error bdb-error? + &bdb-lock-deadlock bdb-lock-deadlock? + &bdb-lock-not-granted bdb-lock-not-granted? + &bdb-old-db-version bdb-old-db-version? + &bdb-db-handle-dead bdb-db-handle-dead? + &bdb-secondary-index-bad bdb-secondary-index-bad? + &bdb-invalid-flag bdb-invalid-flag? + + bdb-db? + bdb-env? + bdb-mpoolfile? + bdb-txn? + bdb-dbc? + + bdb-env-create + bdb-env-open + bdb-env-close + ;bdb-env-remove + + bdb-create + bdb-open + bdb-close + bdb-put + bdb-get + bdb-del + bdb-truncate + bdb-sync + ;bdb-create-cursor + ;bdb-cursor-cget + + bdb-begin-transaction + bdb-abort-transaction + bdb-commit-transaction)) + +(define-structure berkeley-db berkeley-db-interface + (open scheme + srfi-1 + srfi-34 + srfi-35 + fluids + weak + byte-vectors + extended-ports + ascii + let-opt + bitwise + define-record-types + finite-types + external-calls) + (files bdb)) + \ No newline at end of file