more fixes, simplified

This commit is contained in:
eknauel 2004-09-20 07:03:52 +00:00
parent 0a9aefb9d4
commit 321045b329
4 changed files with 444 additions and 537 deletions

383
c/bdb.c
View File

@ -52,6 +52,31 @@ 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;
static s48_value scheme_DB_DONOTINDEX = S48_FALSE;
static s48_value scheme_DB_FILEOPEN = S48_FALSE;
static s48_value scheme_DB_KEYEMPTY = S48_FALSE;
static s48_value scheme_DB_KEYEXIST = S48_FALSE;
static s48_value scheme_DB_LOCK_DEADLOCK = S48_FALSE;
static s48_value scheme_DB_LOCK_NOTGRANTED = S48_FALSE;
static s48_value scheme_DB_NOSERVER = S48_FALSE;
static s48_value scheme_DB_NOSERVER_HOME = S48_FALSE;
static s48_value scheme_DB_NOSERVER_ID = S48_FALSE;
static s48_value scheme_DB_NOTFOUND = S48_FALSE;
static s48_value scheme_DB_OLD_VERSION = S48_FALSE;
static s48_value scheme_DB_PAGE_NOTFOUND = S48_FALSE;
static s48_value scheme_DB_REP_DUPMASTER = S48_FALSE;
static s48_value scheme_DB_REP_HANDLE_DEAD = S48_FALSE;
static s48_value scheme_DB_REP_HOLDELECTION = S48_FALSE;
static s48_value scheme_DB_REP_ISPERM = S48_FALSE;
static s48_value scheme_DB_REP_NEWMASTER = S48_FALSE;
static s48_value scheme_DB_REP_NEWSITE = S48_FALSE;
static s48_value scheme_DB_REP_NOTPERM = S48_FALSE;
static s48_value scheme_DB_REP_OUTDATED = S48_FALSE;
static s48_value scheme_DB_REP_UNAVAIL = S48_FALSE;
static s48_value scheme_DB_RUNRECOVERY = S48_FALSE;
static s48_value scheme_DB_SECONDARY_BAD = S48_FALSE;
static s48_value scheme_DB_VERIFY_BAD = S48_FALSE;
/* initialise DB_TYPES */
static s48_value scheme_DB_BTREE = S48_FALSE;
static s48_value scheme_DB_HASH = S48_FALSE;
@ -139,33 +164,63 @@ s48_value scsh_bdb_env_create(s48_value sflags)
}
/* close an environment */
s48_value scsh_bdb_env_close(s48_value env, s48_value sflags)
s48_value scsh_bdb_env_close(s48_value env)
{
int res;
DB_ENV *dbenv;
u_int32_t flags;
S48_DECLARE_GC_PROTECT(1);
S48_DECLARE_GC_PROTECT(2);
S48_GC_PROTECT_2(env, sflags);
S48_GC_PROTECT_1(env);
dbenv = scsh_extract_dbenv(env);
flags = s48_extract_integer(sflags);
S48_GC_UNPROTECT();
res = dbenv->close(dbenv, flags);
res = dbenv->close(dbenv, 0);
CHECK_BDB_RESULT_CODE(res);
return S48_TRUE;
}
/* remove a database */
/* s48_value scsh_bdb_dbremove(...) */
/* s48_value scsh_bdb_dbremove(s48_value senv_handle, s48_value stxnid, */
/* s48_value sfile, s48_value sdatabase, */
/* s48_value sflags) */
/* { */
/* DB_ENV->dbremove(); */
/* DB_ENV *dbenv; */
/* DB_TXN *txnid; */
/* DB *dbp; */
/* char *file; */
/* u_int32_t flags; */
/* int res; */
/* S48_DECLARE_GC_PROTECT(5); */
/* S48_GC_PROTECT_5(senv_handle, stxnid, sfile, sdatabase, sflags); */
/* dbenv = scsh_extract_dbenv(senv_handle); */
/* txnid = EXTRACT_OPTIONAL_TXNID(stxnid); */
/* file = s48_extract_string(sfile); */
/* dbp = scsh_extract_db(sdatabase); */
/* flags = s48_extract_integer(sflags); */
/* S48_GC_UNPROTECT(); */
/* res = DB_ENV->dbremove(dbenv, txnid, file, dbp, flags); */
/* CHECK_BDB_RESULT_CODE(res); */
/* } */
/* rename a database */
/* s48_value scsh_bdb_dbrename(...) */
/* s48_value scsh_bdb_dbrename(s48_value senv_handle, s48_value stxnid, */
/* s48_value sfile, s48_value sdatabase, */
/* s48_value snewname, s48_value sflags) */
/* { */
/* DB_ENV *dbenv; */
/* DB_TXN *txnid; */
/* char *file, *database, *newname; */
/* u_int32_t flags; */
/* S48_DECLARE_GC_PROTECT(6); */
/* S48_GC_UNPROTECT_6(senv_handle, stxnid, sfile, sdatabase, snewname, sflags); */
/* DB_ENV->dbrename(); */
/* } */
@ -314,7 +369,7 @@ s48_value scsh_bdb_truncate(s48_value db, s48_value stxnid, s48_value sflags)
res = dbp->truncate(dbp, txnid, countp, flags);
CHECK_BDB_RESULT_CODE(res);
return S48_TRUE;
return s48_enter_integer(res);
}
s48_value scsh_bdb_sync(s48_value db)
@ -385,7 +440,7 @@ s48_value scsh_bdb_put(s48_value db, s48_value skey, s48_value sdata,
res = dbp->put(dbp, txnid, &key, &data, flags);
CHECK_BDB_RESULT_CODE(res);
return scsh_enter_DBT_as_bytevector(&key);
return S48_TRUE;
}
/* Get DBT to corresponding key */
@ -408,9 +463,17 @@ s48_value scsh_bdb_get(s48_value handle, s48_value skey,
S48_GC_UNPROTECT();
res = dbp->get(dbp, txnid, &key, &data, flags);
switch (res) {
case DB_NOTFOUND:
case DB_KEYEMPTY:
return s48_enter_integer(res);
break;
default:
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,
@ -556,225 +619,87 @@ void scsh_init_bdb_bindings(void)
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);
ENTER_INTEGER_CONSTANT(scheme_DB_RPCCLIENT, DB_RPCCLIENT);
ENTER_INTEGER_CONSTANT(scheme_DB_INIT_LOCK, DB_INIT_LOCK);
ENTER_INTEGER_CONSTANT(scheme_DB_JOINENV, DB_JOINENV);
ENTER_INTEGER_CONSTANT(scheme_DB_INIT_MPOOL, DB_INIT_MPOOL);
ENTER_INTEGER_CONSTANT(scheme_DB_INIT_LOG, DB_INIT_LOG);
ENTER_INTEGER_CONSTANT(scheme_DB_INIT_REP, DB_INIT_REP);
ENTER_INTEGER_CONSTANT(scheme_DB_INIT_TXN, DB_INIT_TXN);
ENTER_INTEGER_CONSTANT(scheme_DB_RECOVER, DB_RECOVER);
ENTER_INTEGER_CONSTANT(scheme_DB_RECOVER_FATAL, DB_RECOVER_FATAL);
ENTER_INTEGER_CONSTANT(scheme_DB_USE_ENVIRON, DB_USE_ENVIRON);
ENTER_INTEGER_CONSTANT(scheme_DB_USE_ENVIRON_ROOT, DB_USE_ENVIRON_ROOT);
ENTER_INTEGER_CONSTANT(scheme_DB_CREATE, DB_CREATE);
ENTER_INTEGER_CONSTANT(scheme_DB_LOCKDOWN, DB_LOCKDOWN);
ENTER_INTEGER_CONSTANT(scheme_DB_PRIVATE, DB_PRIVATE);
ENTER_INTEGER_CONSTANT(scheme_DB_SYSTEM_MEM, DB_SYSTEM_MEM);
ENTER_INTEGER_CONSTANT(scheme_DB_THREAD, DB_THREAD);
ENTER_INTEGER_CONSTANT(scheme_DB_AUTO_COMMIT, DB_AUTO_COMMIT);
ENTER_INTEGER_CONSTANT(scheme_DB_DIRTY_READ, DB_DIRTY_READ);
ENTER_INTEGER_CONSTANT(scheme_DB_EXCL, DB_EXCL);
ENTER_INTEGER_CONSTANT(scheme_DB_NOMMAP, DB_NOMMAP);
ENTER_INTEGER_CONSTANT(scheme_DB_RDONLY, DB_RDONLY);
ENTER_INTEGER_CONSTANT(scheme_DB_SYSTEM_MEM, DB_SYSTEM_MEM);
ENTER_INTEGER_CONSTANT(scheme_DB_TRUNCATE, DB_TRUNCATE);
ENTER_INTEGER_CONSTANT(scheme_DB_NOSYNC, DB_NOSYNC);
ENTER_INTEGER_CONSTANT(scheme_DB_CONSUME, DB_CONSUME);
ENTER_INTEGER_CONSTANT(scheme_DB_CONSUME_WAIT, DB_CONSUME_WAIT);
ENTER_INTEGER_CONSTANT(scheme_DB_GET_BOTH, DB_GET_BOTH);
ENTER_INTEGER_CONSTANT(scheme_DB_RMW, DB_RMW);
ENTER_INTEGER_CONSTANT(scheme_DB_MULTIPLE, DB_MULTIPLE);
ENTER_INTEGER_CONSTANT(scheme_DB_SET_RECNO, DB_SET_RECNO);
ENTER_INTEGER_CONSTANT(scheme_DB_APPEND, DB_APPEND);
ENTER_INTEGER_CONSTANT(scheme_DB_NODUPDATA, DB_NODUPDATA);
ENTER_INTEGER_CONSTANT(scheme_DB_NOOVERWRITE, DB_NOOVERWRITE);
ENTER_INTEGER_CONSTANT(scheme_DB_CURRENT, DB_CURRENT);
ENTER_INTEGER_CONSTANT(scheme_DB_FIRST, DB_FIRST);
ENTER_INTEGER_CONSTANT(scheme_DB_WRITECURSOR, DB_WRITECURSOR);
ENTER_INTEGER_CONSTANT(scheme_DB_GET_BOTH_RANGE, DB_GET_BOTH_RANGE);
ENTER_INTEGER_CONSTANT(scheme_DB_GET_RECNO, DB_GET_RECNO);
ENTER_INTEGER_CONSTANT(scheme_DB_JOIN_ITEM, DB_JOIN_ITEM);
ENTER_INTEGER_CONSTANT(scheme_DB_LAST, DB_LAST);
ENTER_INTEGER_CONSTANT(scheme_DB_NEXT, DB_NEXT);
ENTER_INTEGER_CONSTANT(scheme_DB_NEXT_DUP, DB_NEXT_DUP);
ENTER_INTEGER_CONSTANT(scheme_DB_NEXT_NODUP, DB_NEXT_NODUP);
ENTER_INTEGER_CONSTANT(scheme_DB_PREV, DB_PREV);
ENTER_INTEGER_CONSTANT(scheme_DB_SET, DB_SET);
ENTER_INTEGER_CONSTANT(scheme_DB_SET_RANGE, DB_SET_RANGE);
ENTER_INTEGER_CONSTANT(scheme_DB_MULTIPLE_KEY, DB_MULTIPLE_KEY);
ENTER_INTEGER_CONSTANT(scheme_DB_TXN_NOSYNC, DB_TXN_NOSYNC);
ENTER_INTEGER_CONSTANT(scheme_DB_TXN_NOWAIT, DB_TXN_NOWAIT);
ENTER_INTEGER_CONSTANT(scheme_DB_TXN_SYNC, DB_TXN_SYNC);
ENTER_INTEGER_CONSTANT(scheme_DB_BTREE, DB_BTREE);
ENTER_INTEGER_CONSTANT(scheme_DB_HASH, DB_HASH);
ENTER_INTEGER_CONSTANT(scheme_DB_QUEUE, DB_QUEUE);
ENTER_INTEGER_CONSTANT(scheme_DB_RECNO, DB_RECNO);
ENTER_INTEGER_CONSTANT(scheme_DB_UNKNOWN, DB_UNKNOWN);
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);
/* return codes */
ENTER_INTEGER_CONSTANT(scheme_DB_DONOTINDEX, DB_DONOTINDEX);
ENTER_INTEGER_CONSTANT(scheme_DB_FILEOPEN, DB_FILEOPEN);
ENTER_INTEGER_CONSTANT(scheme_DB_KEYEMPTY, DB_KEYEMPTY);
ENTER_INTEGER_CONSTANT(scheme_DB_KEYEXIST, DB_KEYEXIST);
ENTER_INTEGER_CONSTANT(scheme_DB_LOCK_DEADLOCK, DB_LOCK_DEADLOCK);
ENTER_INTEGER_CONSTANT(scheme_DB_LOCK_NOTGRANTED, DB_LOCK_NOTGRANTED);
ENTER_INTEGER_CONSTANT(scheme_DB_NOSERVER, DB_NOSERVER);
ENTER_INTEGER_CONSTANT(scheme_DB_NOSERVER_HOME, DB_NOSERVER_HOME);
ENTER_INTEGER_CONSTANT(scheme_DB_NOSERVER_ID, DB_NOSERVER_ID);
ENTER_INTEGER_CONSTANT(scheme_DB_NOTFOUND, DB_NOTFOUND);
ENTER_INTEGER_CONSTANT(scheme_DB_OLD_VERSION, DB_OLD_VERSION);
ENTER_INTEGER_CONSTANT(scheme_DB_PAGE_NOTFOUND, DB_PAGE_NOTFOUND);
ENTER_INTEGER_CONSTANT(scheme_DB_REP_DUPMASTER, DB_REP_DUPMASTER);
ENTER_INTEGER_CONSTANT(scheme_DB_REP_HANDLE_DEAD, DB_REP_HANDLE_DEAD);
ENTER_INTEGER_CONSTANT(scheme_DB_REP_HOLDELECTION, DB_REP_HOLDELECTION);
ENTER_INTEGER_CONSTANT(scheme_DB_REP_ISPERM, DB_REP_ISPERM);
ENTER_INTEGER_CONSTANT(scheme_DB_REP_NEWMASTER, DB_REP_NEWMASTER);
ENTER_INTEGER_CONSTANT(scheme_DB_REP_NEWSITE, DB_REP_NEWSITE);
ENTER_INTEGER_CONSTANT(scheme_DB_REP_NOTPERM, DB_REP_NOTPERM);
ENTER_INTEGER_CONSTANT(scheme_DB_REP_OUTDATED, DB_REP_OUTDATED);
ENTER_INTEGER_CONSTANT(scheme_DB_REP_UNAVAIL, DB_REP_UNAVAIL);
ENTER_INTEGER_CONSTANT(scheme_DB_RUNRECOVERY, DB_RUNRECOVERY);
ENTER_INTEGER_CONSTANT(scheme_DB_SECONDARY_BAD, DB_SECONDARY_BAD);
ENTER_INTEGER_CONSTANT(scheme_DB_VERIFY_BAD, DB_VERIFY_BAD);
/* export functions to scheme */
S48_EXPORT_FUNCTION(scsh_bdb_create);

View File

@ -32,9 +32,9 @@ s48_value scsh_enter_dbenv(DB_ENV *h);
#define CHECK_BDB_RESULT_CODE(res) \
do { \
if (res < 0) \
s48_raise_os_error(res); \
if (res > 0) \
s48_raise_os_error(res); \
if (res < 0) \
return s48_enter_integer(res); \
} while (0);
@ -46,3 +46,8 @@ s48_value scsh_enter_dbenv(DB_ENV *h);
#define EXTRACT_OPTIONAL_ENV(env) \
((env == S48_FALSE) ? NULL : scsh_extract_dbenv(env))
#define ENTER_INTEGER_CONSTANT(scm_value, c_value) \
S48_GC_PROTECT_GLOBAL(scm_value); \
scm_value = s48_enter_integer(c_value); \
s48_define_exported_binding(#scm_value, scm_value);

View File

@ -18,6 +18,7 @@
(define $current-env (make-fluid #f))
(define $current-db (make-fluid #f))
(define $current-transaction-id (make-fluid #f))
(define $current-flags (make-fluid #f))
(define (current-env)
(fluid $current-env))
@ -28,29 +29,35 @@
(define (current-transaction-id)
(fluid $current-transaction-id))
(define (with-env db-env thunk)
(define (current-flags)
(fluid $current-flags))
(define (with-database-env db-env thunk)
(let-fluid $current-env db-env thunk))
(define (with-db db thunk)
(define (with-database db thunk)
(let-fluid $current-db db thunk))
(define (with-transaction options proc)
(define (with-database-flags flags thunk)
(let-fluid $current-flags flags thunk))
(define (as-transaction options proc)
(let-fluid
$current-transaction-id
(bdb-begin-transaction options)
(begin-transaction options)
(lambda ()
(proc (lambda ()
(bdb-abort-transaction (current-transaction-id))))
(bdb-commit-transaction (current-transaction-id)))))
(abort-transaction (current-transaction-id))))
(commit-transaction (current-transaction-id)))))
;; constants
(define-finite-type bdb-flags :bdb-flags
(define-finite-type flag :flag
(id)
bdb-flags-object?
bdb-flags-elements
bdb-flags-name
bdb-flags-index
(id bdb-flags-id)
flag-object?
flag-elements
flag-name
flag-index
(id flag-id)
((default 0)
(rpc-client (lookup-shared-value "scheme_DB_RPCCLIENT"))
(join-env (lookup-shared-value "scheme_DB_JOINENV"))
@ -107,27 +114,44 @@
(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-finite-type return-code :return-code
(id)
return-code-object?
return-code-elements
return-code-name
return-code-index
(id return-code-value)
((do-not-index (lookup-shared-value "scheme_DB_DONOTINDEX"))
(file-open (lookup-shared-value "scheme_DB_FILEOPEN"))
(key-empty (lookup-shared-value "scheme_DB_KEYEMPTY"))
(key-exists (lookup-shared-value "scheme_DB_KEYEXIST"))
(lock-deadlock (lookup-shared-value "scheme_DB_LOCK_DEADLOCK"))
(lock-not-granted (lookup-shared-value "scheme_DB_LOCK_NOTGRANTED"))
(no-server (lookup-shared-value "scheme_DB_NOSERVER"))
(no-server-home (lookup-shared-value "scheme_DB_NOSERVER_HOME"))
(no-server-id (lookup-shared-value "scheme_DB_NOSERVER_ID"))
(not-found (lookup-shared-value "scheme_DB_NOTFOUND"))
(old-version (lookup-shared-value "scheme_DB_OLD_VERSION"))
(page-not-found (lookup-shared-value "scheme_DB_PAGE_NOTFOUND"))
(rep-dup-masters (lookup-shared-value "scheme_DB_REP_DUPMASTER"))
(rep-handle-dead (lookup-shared-value "scheme_DB_REP_HANDLE_DEAD"))
(rep-hold-election (lookup-shared-value "scheme_DB_REP_HOLDELECTION"))
(rep-is-permanent (lookup-shared-value "scheme_DB_REP_ISPERM"))
(rep-is-new-master (lookup-shared-value "scheme_DB_REP_NEWMASTER"))
(rep-is-new-site (lookup-shared-value "scheme_DB_REP_NEWSITE"))
(rep-is-not-perm (lookup-shared-value "scheme_DB_REP_NOTPERM"))
(rep-is-outdated (lookup-shared-value "scheme_DB_REP_OUTDATED"))
(rep-unavailable (lookup-shared-value "scheme_DB_REP_UNAVAIL"))
(run-recovery (lookup-shared-value "scheme_DB_RUNRECOVERY"))
(secondary-bad (lookup-shared-value "scheme_DB_SECONDARY_BAD"))
(verify-bad (lookup-shared-value "scheme_DB_VERIFY_BAD"))))
(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 (flags->value flags)
(fold
(lambda (f flag)
(bitwise-ior (flag-id f) flag))
(flag-id (flag default))
(if (list? flags) flags (list flags))))
(define-finite-type database-type :database-type
(id)
@ -145,7 +169,8 @@
;;; define error conditions
;;; with subconditions
(define-condition-type &bdb-error &condition
bdb-error?)
bdb-error?
(code bdb-error-code))
;;; without subconditions
@ -174,11 +199,22 @@
(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))))
(list
(cons (return-code-value
(return-code lock-deadlock))
&bdb-lock-deadlock)
(cons (return-code-value
(return-code lock-not-granted))
&bdb-lock-not-granted)
(cons (return-code-value
(return-code old-version))
&bdb-old-db-version)
(cons (return-code-value
(return-code rep-handle-dead))
&bdb-db-handle-dead)
(cons (return-code-value
(return-code secondary-bad))
&bdb-secondary-index-bad))))
(lambda (return-object)
(cond
((assoc return-object alist)
@ -190,117 +226,105 @@
(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-record-type database :database
(make-database c-pointer)
database?
(c-pointer database-c-pointer))
(define-exported-binding "bdb-db" :bdb-db)
(define-exported-binding "bdb-db" :database)
;;; 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-record-type database-env :database-env
(make-database-env c-pointer weak-list)
database-env?
(c-pointer database-env-c-pointer)
(weak-list database-env-weak-list set-database-env-weak-list!))
(define-exported-binding "bdb-env" :bdb-env)
(define-exported-binding "bdb-env" :database-env)
(define (bdb-env-weak-list-add! session thing)
(set-bdb-env-weak-list!
session (cons-weak thing (bdb-env-weak-list session))))
(define (database-env-weak-list-add! db-env thing)
(set-database-env-weak-list!
db-env (cons-weak thing (database-env-weak-list db-env))))
(define (bdb-env-weak-list-filter! session)
(set-bdb-env-weak-list!
session (filter-collected (bdb-env-weak-list session))))
(define (database-env-weak-list-filter! db-env)
(set-database-env-weak-list!
db-env (filter-collected (database-env-weak-list db-env))))
(define (bdb-env-finalizer-free session)
(bdb-env-close session))
(define (database-env-finalizer-free db-env)
(database-env-close db-env))
(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)))
(define (database-env-finalizer db-env)
(database-env-weak-list-filter! db-env)
(if (null? (database-env-weak-list db-env))
(add-finalizer! db-env database-env-finalizer-free)
(add-finalizer! db-env database-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-record-type mpoolfile :mpoolfile
(make-mpoolfile c-pointer)
mpoolfile?
(c-pointer mpoolfile-c-pointer))
(define-exported-binding "bdb-mpoolfile" :bdb-mpoolfile)
(define-exported-binding "bdb-mpoolfile" :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-record-type transaction :transaction
(make-transaction c-pointer)
transaction?
(c-pointer transaction-c-pointer))
(define-exported-binding "bdb-txn" :bdb-txn)
(define-exported-binding "bdb-txn" :transaction)
;;; DB Cursor : DBC
(define-record-type bdb-dbc :bdb-dbc
(make-bdb-dbc c-pointer)
bdb-dbc?
(c-pointer bdb-dbc-c-pointer))
(define-record-type cursor :cursor
(make-cursor c-pointer)
cursor?
(c-pointer cursor-c-pointer))
(define-exported-binding "bdb-dbc" :bdb-dbc)
(define-exported-binding "bdb-dbc" :cursor)
(import-lambda-definition bdb-env-create-int (flags)
"scsh_bdb_env_create")
(define bdb-env-create
(let ((valid-flags (list (bdb-flags rpc-client))))
(define make-database-env
(lambda args
(let-optionals args
((flags '()))
(let ((handle
(bdb-env-create-int (flag-one-of valid-flags flags))))
((flags (or (current-flags) '())))
(let ((handle (bdb-env-create-int (flags->value flags))))
(if (integer? handle)
(raise-bdb-condition handle)
(begin
(add-finalizer! handle bdb-env-close)
handle)))))))
(add-finalizer! handle database-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)
(define (database-env-open env-handle home-dir . args)
(let-optionals args
((flags '())
((flags (or (current-flags) '()))
(mode 0))
(let ((ret-object
(let ((result
(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))))))
env-handle home-dir (flags->value flags) mode)))
(if (integer? result)
(raise-bdb-condition result)
(values)))))
(import-lambda-definition
bdb-env-close-int
(env-handle flags)
(env-handle)
"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)))
(define (database-env-close env-handle)
(let ((result (bdb-env-close-int env-handle)))
(if (integer? result)
(raise-bdb-condition result)
(values))))
(import-lambda-definition
bdb-env-remove-int
@ -322,174 +346,124 @@
(env-handle flags)
"scsh_bdb_create")
(define (bdb-create . args)
(let ((valid-flags (list (bdb-flags xa-create))))
(define (make-database . args)
(let-optionals args
((env (or (current-env) #f))
(flags '()))
(flags (or (current-flags) '())))
(let ((handle
(bdb-create-int
env
(flag-one-of valid-flags flags))))
(bdb-create-int env (flags->value flags))))
(if (integer? handle)
(raise-bdb-condition handle)
(begin
(add-finalizer! handle bdb-close)
handle))))))
(add-finalizer! handle close-database)
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)
(define (open-database db-handle db-file . args)
(let-optionals args
((type (database-type binary-tree))
(flags '())
(flags (or (current-flags) '()))
(mode 0)
(database (or (current-db) #f))
(database-name #f)
(txn-id (or (current-transaction-id) #f)))
(let ((ret-object
(bdb-open-int db-handle db-file database txn-id
(let ((result
(bdb-open-int db-handle db-file database-name 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))))))
(flags->value flags) mode)))
(if (integer? result)
(raise-bdb-condition result)
(values)))))
(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)
(define (close-database 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))))))
((flags (or (current-flags) '())))
(let ((result
(bdb-close-int db-handle (flags->value flags))))
(if (integer? result)
(raise-bdb-condition result)
(values)))))
(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)
(define (database-put 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))))))
(flags (or (current-flags) '())))
(let ((result (bdb-put-int
db-handle key data
txn-id (flags->value flags))))
(if (integer? result)
(raise-bdb-condition result)
(values)))))
(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)
(define (database-get 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))))))
(flags (or (current-flags) '())))
(let ((result (bdb-get-int db-handle key txn-id (flags->value flags))))
(if (integer? result)
(if (or (= result -30990) (= result -30997))
#f
(raise-bdb-condition result))
result))))
(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)
(define (database-delete-item 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))))))
(flags (or (current-flags) '())))
(let ((result
(bdb-del-int db-handle key txn-id (flags->value flags))))
(if (integer? result)
(raise-bdb-condition result)
(values)))))
(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)
(define (database-truncate 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))))))
(flags (or (current-flags) '())))
(let ((result
(bdb-truncate-int db-handle txn-id (flags->value flags))))
(if (integer? result)
(raise-bdb-condition result)
result))))
(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))))
(define (database-sync db-handle)
(let ((result (bdb-sync-int db-handle)))
(if (integer? result)
(raise-bdb-condition result)
(values))))
(import-lambda-definition
bdb-create-cursor-int
@ -522,49 +496,37 @@
(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)
(define (begin-transaction 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))))))
(flags (or (current-flags) '())))
(let ((result (bdb-txn-begin-int db-env parent (flags->value flags))))
(if (integer? result)
(raise-bdb-condition result)
(values)))))
(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)))
(define (abort-transaction txn-id)
(let ((result (bdb-txn-abort-int txn-id)))
(if (integer? result)
(raise-bdb-condition result)
(values))))
(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)
(define (commit-transaction 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))))))
((flags (or (current-flags) '())))
(let ((result (bdb-txn-commit-int txn-id (flags->value))))
(if (integer? result)
(raise-bdb-condition result)
(values)))))
(define (string->byte-vector string)
(let* ((length (string-length string))

View File

@ -1,9 +1,20 @@
(define-interface berkeley-db-interface
(export
bdb-flags-object?
bdb-flags-elements
bdb-flags-name
(bdb-flags :syntax)
with-database-env
with-database
with-database-flags
as-transaction
flag-object?
flag-elements
flag-name
(flag :syntax)
return-code-object?
return-code-elements
return-code-name
(return-code :syntax)
database-type-object?
database-type-elements
@ -18,31 +29,35 @@
&bdb-secondary-index-bad bdb-secondary-index-bad?
&bdb-invalid-flag bdb-invalid-flag?
bdb-db?
bdb-env?
bdb-mpoolfile?
bdb-txn?
bdb-dbc?
database?
database-env?
mpoolfile?
transaction?
cursor?
bdb-env-create
bdb-env-open
bdb-env-close
;bdb-env-remove
make-database-env
database-env-open
database-env-close
bdb-create
bdb-open
bdb-close
bdb-put
bdb-get
bdb-del
bdb-truncate
bdb-sync
;bdb-create-cursor
;bdb-cursor-cget
make-database
open-database
close-database
bdb-begin-transaction
bdb-abort-transaction
bdb-commit-transaction))
database-put
database-get
database-delete-item
database-truncate
database-sync
begin-transaction
abort-transaction
commit-transaction
string->byte-vector
byte-vector->string
value->byte-vector
byte-vector->value))
(define-structure berkeley-db berkeley-db-interface
(open scheme