scsh-conservatory
/
scsh-bdb
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

*** empty log message ***

This commit is contained in:
eknauel 2004-09-17 10:50:50 +00:00
commit 03ab5b5471
15 changed files with 1918 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
.gitignore vendored Normal file
View File

@ -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

2
AUTHORS Normal file
View File

@ -0,0 +1,2 @@
Daniel Brintzinger
Eric Knauel

26
COPYING Normal file
View File

@ -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.

0
ChangeLog Normal file
View File

229
INSTALL Normal file
View File

@ -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.

1
Makefile.am Normal file
View File

@ -0,0 +1 @@
SUBDIRS = c

0
NEWS Normal file
View File

0
README Normal file
View File

8
c/Makefile.am Normal file
View File

@ -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=

797
c/bdb.c Normal file
View File

@ -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);
}

48
c/bdb.h Normal file
View File

@ -0,0 +1,48 @@
#include <sys/types.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#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))

39
configure.in Normal file
View File

@ -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])

74
pkg-def.scm Normal file
View File

@ -0,0 +1,74 @@
(define-package "bdb" (0 1 0)
((install-lib-version (1 0))
(options (bdb-prefix "Uses Berkeley DB library with prefix" "<dir>" #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)
)

603
scheme/bdb.scm Normal file
View File

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

63
scheme/packages.scm Normal file
View File

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