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

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

393
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_NOWAIT = S48_FALSE;
static s48_value scheme_DB_TXN_SYNC = 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 */ /* initialise DB_TYPES */
static s48_value scheme_DB_BTREE = S48_FALSE; static s48_value scheme_DB_BTREE = S48_FALSE;
static s48_value scheme_DB_HASH = 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 */ /* 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; int res;
DB_ENV *dbenv; DB_ENV *dbenv;
u_int32_t flags; S48_DECLARE_GC_PROTECT(1);
S48_DECLARE_GC_PROTECT(2); S48_GC_PROTECT_1(env);
S48_GC_PROTECT_2(env, sflags);
dbenv = scsh_extract_dbenv(env); dbenv = scsh_extract_dbenv(env);
flags = s48_extract_integer(sflags);
S48_GC_UNPROTECT(); S48_GC_UNPROTECT();
res = dbenv->close(dbenv, flags); res = dbenv->close(dbenv, 0);
CHECK_BDB_RESULT_CODE(res); CHECK_BDB_RESULT_CODE(res);
return S48_TRUE; return S48_TRUE;
} }
/* remove a database */ /* 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, */
/* DB_ENV->dbremove(); */ /* s48_value sflags) */
/* } */ /* { */
/* 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 */ /* 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(); */ /* 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); res = dbp->truncate(dbp, txnid, countp, flags);
CHECK_BDB_RESULT_CODE(res); CHECK_BDB_RESULT_CODE(res);
return S48_TRUE; return s48_enter_integer(res);
} }
s48_value scsh_bdb_sync(s48_value db) 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); res = dbp->put(dbp, txnid, &key, &data, flags);
CHECK_BDB_RESULT_CODE(res); CHECK_BDB_RESULT_CODE(res);
return scsh_enter_DBT_as_bytevector(&key); return S48_TRUE;
} }
/* Get DBT to corresponding key */ /* Get DBT to corresponding key */
@ -408,8 +463,16 @@ s48_value scsh_bdb_get(s48_value handle, s48_value skey,
S48_GC_UNPROTECT(); S48_GC_UNPROTECT();
res = dbp->get(dbp, txnid, &key, &data, flags); res = dbp->get(dbp, txnid, &key, &data, flags);
CHECK_BDB_RESULT_CODE(res);
return scsh_enter_DBT_as_bytevector(&data); 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 */ /* Delete DBT to corresponding key */
@ -556,225 +619,87 @@ void scsh_init_bdb_bindings(void)
bdb_dbc_record_type = s48_get_imported_binding("bdb-dbc"); bdb_dbc_record_type = s48_get_imported_binding("bdb-dbc");
/* flag constants */ /* flag constants */
S48_GC_PROTECT_GLOBAL(scheme_DB_RPCCLIENT); ENTER_INTEGER_CONSTANT(scheme_DB_RPCCLIENT, DB_RPCCLIENT);
scheme_DB_RPCCLIENT = s48_enter_integer(DB_RPCCLIENT); ENTER_INTEGER_CONSTANT(scheme_DB_INIT_LOCK, DB_INIT_LOCK);
s48_define_exported_binding("scheme_DB_RPCCLIENT",scheme_DB_RPCCLIENT); ENTER_INTEGER_CONSTANT(scheme_DB_JOINENV, DB_JOINENV);
ENTER_INTEGER_CONSTANT(scheme_DB_INIT_MPOOL, DB_INIT_MPOOL);
S48_GC_PROTECT_GLOBAL(scheme_DB_INIT_LOCK); ENTER_INTEGER_CONSTANT(scheme_DB_INIT_LOG, DB_INIT_LOG);
scheme_DB_INIT_LOCK = s48_enter_integer(DB_INIT_LOCK); ENTER_INTEGER_CONSTANT(scheme_DB_INIT_REP, DB_INIT_REP);
s48_define_exported_binding("scheme_DB_INIT_LOCK",scheme_DB_INIT_LOCK); ENTER_INTEGER_CONSTANT(scheme_DB_INIT_TXN, DB_INIT_TXN);
ENTER_INTEGER_CONSTANT(scheme_DB_RECOVER, DB_RECOVER);
S48_GC_PROTECT_GLOBAL(scheme_DB_JOINENV); ENTER_INTEGER_CONSTANT(scheme_DB_RECOVER_FATAL, DB_RECOVER_FATAL);
scheme_DB_JOINENV = s48_enter_integer(DB_JOINENV); ENTER_INTEGER_CONSTANT(scheme_DB_USE_ENVIRON, DB_USE_ENVIRON);
s48_define_exported_binding("scheme_DB_JOINENV",scheme_DB_JOINENV); ENTER_INTEGER_CONSTANT(scheme_DB_USE_ENVIRON_ROOT, DB_USE_ENVIRON_ROOT);
ENTER_INTEGER_CONSTANT(scheme_DB_CREATE, DB_CREATE);
S48_GC_PROTECT_GLOBAL(scheme_DB_INIT_MPOOL); ENTER_INTEGER_CONSTANT(scheme_DB_LOCKDOWN, DB_LOCKDOWN);
scheme_DB_INIT_MPOOL = s48_enter_integer(DB_INIT_MPOOL); ENTER_INTEGER_CONSTANT(scheme_DB_PRIVATE, DB_PRIVATE);
s48_define_exported_binding("scheme_DB_INIT_MPOOL",scheme_DB_INIT_MPOOL); ENTER_INTEGER_CONSTANT(scheme_DB_SYSTEM_MEM, DB_SYSTEM_MEM);
ENTER_INTEGER_CONSTANT(scheme_DB_THREAD, DB_THREAD);
S48_GC_PROTECT_GLOBAL(scheme_DB_INIT_LOG); ENTER_INTEGER_CONSTANT(scheme_DB_AUTO_COMMIT, DB_AUTO_COMMIT);
scheme_DB_INIT_LOG = s48_enter_integer(DB_INIT_LOG); ENTER_INTEGER_CONSTANT(scheme_DB_DIRTY_READ, DB_DIRTY_READ);
s48_define_exported_binding("scheme_DB_INIT_LOG",scheme_DB_INIT_LOG); ENTER_INTEGER_CONSTANT(scheme_DB_EXCL, DB_EXCL);
ENTER_INTEGER_CONSTANT(scheme_DB_NOMMAP, DB_NOMMAP);
S48_GC_PROTECT_GLOBAL(scheme_DB_INIT_REP); ENTER_INTEGER_CONSTANT(scheme_DB_RDONLY, DB_RDONLY);
scheme_DB_INIT_REP = s48_enter_integer(DB_INIT_REP); ENTER_INTEGER_CONSTANT(scheme_DB_SYSTEM_MEM, DB_SYSTEM_MEM);
s48_define_exported_binding("scheme_DB_INIT_REP",scheme_DB_INIT_REP); ENTER_INTEGER_CONSTANT(scheme_DB_TRUNCATE, DB_TRUNCATE);
ENTER_INTEGER_CONSTANT(scheme_DB_NOSYNC, DB_NOSYNC);
S48_GC_PROTECT_GLOBAL(scheme_DB_INIT_TXN); ENTER_INTEGER_CONSTANT(scheme_DB_CONSUME, DB_CONSUME);
scheme_DB_INIT_TXN = s48_enter_integer(DB_INIT_TXN); ENTER_INTEGER_CONSTANT(scheme_DB_CONSUME_WAIT, DB_CONSUME_WAIT);
s48_define_exported_binding("scheme_DB_INIT_TXN",scheme_DB_INIT_TXN); ENTER_INTEGER_CONSTANT(scheme_DB_GET_BOTH, DB_GET_BOTH);
ENTER_INTEGER_CONSTANT(scheme_DB_RMW, DB_RMW);
S48_GC_PROTECT_GLOBAL(scheme_DB_RECOVER); ENTER_INTEGER_CONSTANT(scheme_DB_MULTIPLE, DB_MULTIPLE);
scheme_DB_RECOVER = s48_enter_integer(DB_RECOVER); ENTER_INTEGER_CONSTANT(scheme_DB_SET_RECNO, DB_SET_RECNO);
s48_define_exported_binding("scheme_DB_RECOVER",scheme_DB_RECOVER); ENTER_INTEGER_CONSTANT(scheme_DB_APPEND, DB_APPEND);
ENTER_INTEGER_CONSTANT(scheme_DB_NODUPDATA, DB_NODUPDATA);
S48_GC_PROTECT_GLOBAL(scheme_DB_RECOVER_FATAL); ENTER_INTEGER_CONSTANT(scheme_DB_NOOVERWRITE, DB_NOOVERWRITE);
scheme_DB_RECOVER_FATAL = s48_enter_integer(DB_RECOVER_FATAL); ENTER_INTEGER_CONSTANT(scheme_DB_CURRENT, DB_CURRENT);
s48_define_exported_binding("scheme_DB_RECOVER_FATAL",scheme_DB_RECOVER_FATAL); 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_USE_ENVIRON); /* return codes */
scheme_DB_USE_ENVIRON = s48_enter_integer(DB_USE_ENVIRON); ENTER_INTEGER_CONSTANT(scheme_DB_DONOTINDEX, DB_DONOTINDEX);
s48_define_exported_binding("scheme_DB_USE_ENVIRON",scheme_DB_USE_ENVIRON); ENTER_INTEGER_CONSTANT(scheme_DB_FILEOPEN, DB_FILEOPEN);
ENTER_INTEGER_CONSTANT(scheme_DB_KEYEMPTY, DB_KEYEMPTY);
S48_GC_PROTECT_GLOBAL(scheme_DB_USE_ENVIRON_ROOT); ENTER_INTEGER_CONSTANT(scheme_DB_KEYEXIST, DB_KEYEXIST);
scheme_DB_USE_ENVIRON_ROOT = s48_enter_integer(DB_USE_ENVIRON_ROOT); ENTER_INTEGER_CONSTANT(scheme_DB_LOCK_DEADLOCK, DB_LOCK_DEADLOCK);
s48_define_exported_binding("scheme_DB_USE_ENVIRON_ROOT",scheme_DB_USE_ENVIRON_ROOT); ENTER_INTEGER_CONSTANT(scheme_DB_LOCK_NOTGRANTED, DB_LOCK_NOTGRANTED);
ENTER_INTEGER_CONSTANT(scheme_DB_NOSERVER, DB_NOSERVER);
S48_GC_PROTECT_GLOBAL(scheme_DB_CREATE); ENTER_INTEGER_CONSTANT(scheme_DB_NOSERVER_HOME, DB_NOSERVER_HOME);
scheme_DB_CREATE = s48_enter_integer(DB_CREATE); ENTER_INTEGER_CONSTANT(scheme_DB_NOSERVER_ID, DB_NOSERVER_ID);
s48_define_exported_binding("scheme_DB_CREATE",scheme_DB_CREATE); ENTER_INTEGER_CONSTANT(scheme_DB_NOTFOUND, DB_NOTFOUND);
ENTER_INTEGER_CONSTANT(scheme_DB_OLD_VERSION, DB_OLD_VERSION);
S48_GC_PROTECT_GLOBAL(scheme_DB_LOCKDOWN); ENTER_INTEGER_CONSTANT(scheme_DB_PAGE_NOTFOUND, DB_PAGE_NOTFOUND);
scheme_DB_LOCKDOWN = s48_enter_integer(DB_LOCKDOWN); ENTER_INTEGER_CONSTANT(scheme_DB_REP_DUPMASTER, DB_REP_DUPMASTER);
s48_define_exported_binding("scheme_DB_LOCKDOWN",scheme_DB_LOCKDOWN); ENTER_INTEGER_CONSTANT(scheme_DB_REP_HANDLE_DEAD, DB_REP_HANDLE_DEAD);
ENTER_INTEGER_CONSTANT(scheme_DB_REP_HOLDELECTION, DB_REP_HOLDELECTION);
S48_GC_PROTECT_GLOBAL(scheme_DB_PRIVATE); ENTER_INTEGER_CONSTANT(scheme_DB_REP_ISPERM, DB_REP_ISPERM);
scheme_DB_PRIVATE = s48_enter_integer(DB_PRIVATE); ENTER_INTEGER_CONSTANT(scheme_DB_REP_NEWMASTER, DB_REP_NEWMASTER);
s48_define_exported_binding("scheme_DB_PRIVATE",scheme_DB_PRIVATE); ENTER_INTEGER_CONSTANT(scheme_DB_REP_NEWSITE, DB_REP_NEWSITE);
ENTER_INTEGER_CONSTANT(scheme_DB_REP_NOTPERM, DB_REP_NOTPERM);
S48_GC_PROTECT_GLOBAL(scheme_DB_SYSTEM_MEM); ENTER_INTEGER_CONSTANT(scheme_DB_REP_OUTDATED, DB_REP_OUTDATED);
scheme_DB_SYSTEM_MEM = s48_enter_integer(DB_SYSTEM_MEM); ENTER_INTEGER_CONSTANT(scheme_DB_REP_UNAVAIL, DB_REP_UNAVAIL);
s48_define_exported_binding("scheme_DB_SYSTEM_MEM",scheme_DB_SYSTEM_MEM); ENTER_INTEGER_CONSTANT(scheme_DB_RUNRECOVERY, DB_RUNRECOVERY);
ENTER_INTEGER_CONSTANT(scheme_DB_SECONDARY_BAD, DB_SECONDARY_BAD);
S48_GC_PROTECT_GLOBAL(scheme_DB_THREAD); ENTER_INTEGER_CONSTANT(scheme_DB_VERIFY_BAD, DB_VERIFY_BAD);
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 */ /* export functions to scheme */
S48_EXPORT_FUNCTION(scsh_bdb_create); S48_EXPORT_FUNCTION(scsh_bdb_create);

9
c/bdb.h
View File

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

508
scheme/bdb.scm
View File

@ -18,6 +18,7 @@
(define $current-env (make-fluid #f)) (define $current-env (make-fluid #f))
(define $current-db (make-fluid #f)) (define $current-db (make-fluid #f))
(define $current-transaction-id (make-fluid #f)) (define $current-transaction-id (make-fluid #f))
(define $current-flags (make-fluid #f))
(define (current-env) (define (current-env)
(fluid $current-env)) (fluid $current-env))
@ -28,29 +29,35 @@
(define (current-transaction-id) (define (current-transaction-id)
(fluid $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)) (let-fluid $current-env db-env thunk))
(define (with-db db thunk) (define (with-database db thunk)
(let-fluid $current-db 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 (let-fluid
$current-transaction-id $current-transaction-id
(bdb-begin-transaction options) (begin-transaction options)
(lambda () (lambda ()
(proc (lambda () (proc (lambda ()
(bdb-abort-transaction (current-transaction-id)))) (abort-transaction (current-transaction-id))))
(bdb-commit-transaction (current-transaction-id))))) (commit-transaction (current-transaction-id)))))
;; constants ;; constants
(define-finite-type bdb-flags :bdb-flags (define-finite-type flag :flag
(id) (id)
bdb-flags-object? flag-object?
bdb-flags-elements flag-elements
bdb-flags-name flag-name
bdb-flags-index flag-index
(id bdb-flags-id) (id flag-id)
((default 0) ((default 0)
(rpc-client (lookup-shared-value "scheme_DB_RPCCLIENT")) (rpc-client (lookup-shared-value "scheme_DB_RPCCLIENT"))
(join-env (lookup-shared-value "scheme_DB_JOINENV")) (join-env (lookup-shared-value "scheme_DB_JOINENV"))
@ -107,27 +114,44 @@
(txn-nowait (lookup-shared-value "scheme_DB_TXN_NOWAIT")) (txn-nowait (lookup-shared-value "scheme_DB_TXN_NOWAIT"))
(txn-sync (lookup-shared-value "scheme_DB_TXN_SYNC")))) (txn-sync (lookup-shared-value "scheme_DB_TXN_SYNC"))))
(define (fold-flags valid unit given) (define-finite-type return-code :return-code
(fold-right (id)
(lambda (f flag) return-code-object?
(if (member f valid) return-code-elements
(bitwise-ior (bdb-flags-id f) flag) return-code-name
(raise (condition return-code-index
(&bdb-invalid-flag (value given)))))) (id return-code-value)
(bdb-flags-id unit) ((do-not-index (lookup-shared-value "scheme_DB_DONOTINDEX"))
(if (list? given) given (list given)))) (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) (define (flags->value flags)
(cond (fold
((null? given) (lambda (f flag)
(bdb-flags-id (bdb-flags default))) (bitwise-ior (flag-id f) flag))
((member given valid) (flag-id (flag default))
=> (lambda (l) (if (list? flags) flags (list flags))))
(bdb-flags-id (car l))))
(else
(raise
(condition
(&bdb-invalid-flag (value given)))))))
(define-finite-type database-type :database-type (define-finite-type database-type :database-type
(id) (id)
@ -145,7 +169,8 @@
;;; define error conditions ;;; define error conditions
;;; with subconditions ;;; with subconditions
(define-condition-type &bdb-error &condition (define-condition-type &bdb-error &condition
bdb-error?) bdb-error?
(code bdb-error-code))
;;; without subconditions ;;; without subconditions
@ -174,11 +199,22 @@
(define raise-bdb-condition (define raise-bdb-condition
(let ((alist (let ((alist
`((,-30995 ,&bdb-lock-deadlock) (list
(,-30994 ,&bdb-lock-not-granted) (cons (return-code-value
(,-30989 ,&bdb-old-db-version) (return-code lock-deadlock))
(,-30986 ,&bdb-db-handle-dead) &bdb-lock-deadlock)
(,-30977 , &bdb-secondary-index-bad)))) (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) (lambda (return-object)
(cond (cond
((assoc return-object alist) ((assoc return-object alist)
@ -190,117 +226,105 @@
(condition (&bdb-error (condition (&bdb-error
(code return-object))))))))) (code return-object)))))))))
;;; define bdb records ;;; define bdb records
;;; DB handle : DB ;;; DB handle : DB
(define-record-type bdb-db :bdb-db (define-record-type database :database
(make-bdb-db c-pointer) (make-database c-pointer)
bdb-db? database?
(c-pointer bdb-db-c-pointer)) (c-pointer database-c-pointer))
(define-exported-binding "bdb-db" :bdb-db) (define-exported-binding "bdb-db" :database)
;;; DB environement handle : DB_ENV ;;; DB environement handle : DB_ENV
(define-record-type bdb-env :bdb-env (define-record-type database-env :database-env
(make-bdb-env c-pointer weak-list) (make-database-env c-pointer weak-list)
bdb-env? database-env?
(c-pointer bdb-env-c-pointer) (c-pointer database-env-c-pointer)
(weak-list bdb-env-weak-list set-bdb-env-weak-list!)) (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) (define (database-env-weak-list-add! db-env thing)
(set-bdb-env-weak-list! (set-database-env-weak-list!
session (cons-weak thing (bdb-env-weak-list session)))) db-env (cons-weak thing (database-env-weak-list db-env))))
(define (bdb-env-weak-list-filter! session) (define (database-env-weak-list-filter! db-env)
(set-bdb-env-weak-list! (set-database-env-weak-list!
session (filter-collected (bdb-env-weak-list session)))) db-env (filter-collected (database-env-weak-list db-env))))
(define (bdb-env-finalizer-free session) (define (database-env-finalizer-free db-env)
(bdb-env-close session)) (database-env-close db-env))
(define (bdb-env-finalizer session) (define (database-env-finalizer db-env)
(bdb-env-weak-list-filter! session) (database-env-weak-list-filter! db-env)
(if (null? (bdb-env-weak-list session)) (if (null? (database-env-weak-list db-env))
(add-finalizer! session bdb-env-finalizer-free) (add-finalizer! db-env database-env-finalizer-free)
(add-finalizer! session bdb-env-finalizer))) (add-finalizer! db-env database-env-finalizer)))
;;; DB memory poolfile : DB_MPOOLFILE ;;; DB memory poolfile : DB_MPOOLFILE
(define-record-type bdb-mpoolfile :bdb-mpoolfile (define-record-type mpoolfile :mpoolfile
(make-bdb-mpoolfile c-pointer) (make-mpoolfile c-pointer)
bdb-mpoolfile? mpoolfile?
(c-pointer bdb-mpoolfile-c-pointer)) (c-pointer mpoolfile-c-pointer))
(define-exported-binding "bdb-mpoolfile" :bdb-mpoolfile) (define-exported-binding "bdb-mpoolfile" :mpoolfile)
;;; DB transaction : DB_TXN ;;; DB transaction : DB_TXN
(define-record-type bdb-txn :bdb-txn (define-record-type transaction :transaction
(make-bdb-txn c-pointer) (make-transaction c-pointer)
bdb-txn? transaction?
(c-pointer bdb-txn-c-pointer)) (c-pointer transaction-c-pointer))
(define-exported-binding "bdb-txn" :bdb-txn) (define-exported-binding "bdb-txn" :transaction)
;;; DB Cursor : DBC ;;; DB Cursor : DBC
(define-record-type bdb-dbc :bdb-dbc (define-record-type cursor :cursor
(make-bdb-dbc c-pointer) (make-cursor c-pointer)
bdb-dbc? cursor?
(c-pointer bdb-dbc-c-pointer)) (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) (import-lambda-definition bdb-env-create-int (flags)
"scsh_bdb_env_create") "scsh_bdb_env_create")
(define bdb-env-create (define make-database-env
(let ((valid-flags (list (bdb-flags rpc-client)))) (lambda args
(lambda args (let-optionals args
(let-optionals args ((flags (or (current-flags) '())))
((flags '())) (let ((handle (bdb-env-create-int (flags->value flags))))
(let ((handle (if (integer? handle)
(bdb-env-create-int (flag-one-of valid-flags flags)))) (raise-bdb-condition handle)
(if (integer? handle) (begin
(raise-bdb-condition handle) (add-finalizer! handle database-env-close)
(begin handle))))))
(add-finalizer! handle bdb-env-close)
handle)))))))
(import-lambda-definition (import-lambda-definition
bdb-env-open-int bdb-env-open-int
(env-handle db-home flags mode) (env-handle db-home flags mode)
"scsh_bdb_env_open") "scsh_bdb_env_open")
(define bdb-env-open (define (database-env-open env-handle home-dir . args)
(let ((valid-flags (let-optionals args
(list (bdb-flags join-env) (bdb-flags init-lock) ((flags (or (current-flags) '()))
(bdb-flags init-log) (bdb-flags init-mpool) (mode 0))
(bdb-flags init-replication) (bdb-flags init-transactions) (let ((result
(bdb-flags run-recover) (bdb-flags recover-fatal)))) (bdb-env-open-int
(lambda (env-handle home-dir . args) env-handle home-dir (flags->value flags) mode)))
(let-optionals args (if (integer? result)
((flags '()) (raise-bdb-condition result)
(mode 0)) (values)))))
(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 (import-lambda-definition
bdb-env-close-int bdb-env-close-int
(env-handle flags) (env-handle)
"scsh_bdb_env_close") "scsh_bdb_env_close")
(define (bdb-env-close env-handle) (define (database-env-close env-handle)
(let ((ret-object (let ((result (bdb-env-close-int env-handle)))
(bdb-env-close-int env-handle (bdb-flags default)))) (if (integer? result)
(if (integer? ret-object) (raise-bdb-condition result)
(raise-bdb-condition ret-object) (values))))
ret-object)))
(import-lambda-definition (import-lambda-definition
bdb-env-remove-int bdb-env-remove-int
@ -322,174 +346,124 @@
(env-handle flags) (env-handle flags)
"scsh_bdb_create") "scsh_bdb_create")
(define (bdb-create . args) (define (make-database . args)
(let ((valid-flags (list (bdb-flags xa-create)))) (let-optionals args
(let-optionals args ((env (or (current-env) #f))
((env (or (current-env) #f)) (flags (or (current-flags) '())))
(flags '())) (let ((handle
(let ((handle (bdb-create-int env (flags->value flags))))
(bdb-create-int (if (integer? handle)
env (raise-bdb-condition handle)
(flag-one-of valid-flags flags)))) (begin
(if (integer? handle) (add-finalizer! handle close-database)
(raise-bdb-condition handle) handle)))))
(begin
(add-finalizer! handle bdb-close)
handle))))))
(import-lambda-definition (import-lambda-definition
bdb-open-int bdb-open-int
(db-handle db-file database txnid type flags mode) (db-handle db-file database txnid type flags mode)
"scsh_bdb_open") "scsh_bdb_open")
(define bdb-open (define (open-database db-handle db-file . args)
(let ((valid-flags (let-optionals args
(list (bdb-flags auto-commit)(bdb-flags create) ((type (database-type binary-tree))
(bdb-flags dirty-read) (bdb-flags excl) (flags (or (current-flags) '()))
(bdb-flags nommap) (bdb-flags rdonly) (mode 0)
(bdb-flags thread) (bdb-flags truncate)))) (database-name #f)
(lambda (db-handle db-file . args) (txn-id (or (current-transaction-id) #f)))
(let-optionals args (let ((result
((type (database-type binary-tree)) (bdb-open-int db-handle db-file database-name txn-id
(flags '()) (database-type-id type)
(mode 0) (flags->value flags) mode)))
(database (or (current-db) #f)) (if (integer? result)
(txn-id (or (current-transaction-id) #f))) (raise-bdb-condition result)
(let ((ret-object (values)))))
(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 (import-lambda-definition
bdb-close-int bdb-close-int
(db-handle flags) (db-handle flags)
"scsh_bdb_close") "scsh_bdb_close")
(define bdb-close (define (close-database db-handle . args)
(let ((valid-flags (list (bdb-flags nosync)))) (let-optionals args
(lambda (db-handle . args) ((flags (or (current-flags) '())))
(let-optionals args (let ((result
((flags '())) (bdb-close-int db-handle (flags->value flags))))
(let ((ret-object (if (integer? result)
(bdb-close-int (raise-bdb-condition result)
db-handle (values)))))
(fold-flags valid-flags (bdb-flags default) flags))))
(if (integer? ret-object)
(raise-bdb-condition ret-object)
ret-object))))))
(import-lambda-definition (import-lambda-definition
bdb-put-int bdb-put-int
(db-handle key data txn-id flags) (db-handle key data txn-id flags)
"scsh_bdb_put") "scsh_bdb_put")
(define bdb-put (define (database-put db-handle key data . args)
(let ((valid-flags-0 (let-optionals args
(list (bdb-flags append) (bdb-flags nodupdata) ((txn-id (or (current-transaction-id) #f))
(bdb-flags nooverwrite))) (flags (or (current-flags) '())))
(valid-flags-1 (let ((result (bdb-put-int
(list (bdb-flags auto-commit)))) db-handle key data
(lambda (db-handle key data . args) txn-id (flags->value flags))))
(let-optionals args (if (integer? result)
((txn-id (or (current-transaction-id) #f)) (raise-bdb-condition result)
(flags-0 #f) (values)))))
(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 (import-lambda-definition
bdb-get-int bdb-get-int
(db-handle key txn-id flags) (db-handle key txn-id flags)
"scsh_bdb_get") "scsh_bdb_get")
(define bdb-get (define (database-get db-handle key . args)
(let ((valid-flags-0 (let-optionals args
(list (bdb-flags consume) (bdb-flags consume-wait) ((txn-id (or (current-transaction-id) #f))
(bdb-flags get-both) (bdb-flags set-recno))) (flags (or (current-flags) '())))
(valid-flags-1 (let ((result (bdb-get-int db-handle key txn-id (flags->value flags))))
(list (bdb-flags auto-commit) (bdb-flags multiple) (if (integer? result)
(bdb-flags rmw)))) (if (or (= result -30990) (= result -30997))
(lambda (db-handle key . args) #f
(let-optionals args (raise-bdb-condition result))
((txn-id (or (current-transaction-id) #f)) result))))
(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 (import-lambda-definition
bdb-del-int bdb-del-int
(db-handle key txn-id flags) (db-handle key txn-id flags)
"scsh_bdb_del") "scsh_bdb_del")
(define bdb-del (define (database-delete-item db-handle key . args)
(let ((valid-flags (list (bdb-flags auto-commit)))) (let-optionals args
(lambda (db-handle key . args) ((txn-id (or (current-transaction-id) #f))
(let-optionals args (flags (or (current-flags) '())))
((txn-id (or (current-transaction-id) #f)) (let ((result
(flags '())) (bdb-del-int db-handle key txn-id (flags->value flags))))
(let ((ret-object (if (integer? result)
(bdb-del-int db-handle key txn-id (raise-bdb-condition result)
(flag-one-of valid-flags flags)))) (values)))))
(if (integer? ret-object)
(raise-bdb-condition ret-object)
ret-object))))))
(import-lambda-definition (import-lambda-definition
bdb-truncate-int bdb-truncate-int
(db-home txn-id flags) (db-home txn-id flags)
"scsh_bdb_truncate") "scsh_bdb_truncate")
(define bdb-truncate (define (database-truncate db-handle . args)
(let ((valid-flags (list (bdb-flags auto-commit)))) (let-optionals args
(lambda (db-handle . args) ((txn-id (or (current-transaction-id) #f))
(let-optionals args (flags (or (current-flags) '())))
((txn-id (or (current-transaction-id) #f)) (let ((result
(flags '())) (bdb-truncate-int db-handle txn-id (flags->value flags))))
(let ((ret-object (if (integer? result)
(bdb-truncate-int db-handle txn-id (raise-bdb-condition result)
(flag-one-of valid-flags flags)))) result))))
(if (integer? ret-object)
(raise-bdb-condition ret-object)
ret-object))))))
(import-lambda-definition (import-lambda-definition
bdb-sync-int bdb-sync-int
(db-handle) (db-handle)
"scsh_bdb_sync") "scsh_bdb_sync")
(define bdb-sync (define (database-sync db-handle)
(lambda (db-handle) (let ((result (bdb-sync-int db-handle)))
(let ((ret-object (bdb-sync-int db-handle))) (if (integer? result)
(if (integer? ret-object) (raise-bdb-condition result)
(raise-bdb-condition ret-object) (values))))
ret-object))))
(import-lambda-definition (import-lambda-definition
bdb-create-cursor-int bdb-create-cursor-int
@ -522,49 +496,37 @@
(env-handle parent flags) (env-handle parent flags)
"scsh_bdb_txn_begin") "scsh_bdb_txn_begin")
(define bdb-begin-transaction (define (begin-transaction db-env . args)
(let ((valid-flags (let-optionals args
(list (bdb-flags dirty-read) (bdb-flags txn-nosync) ((parent #f)
(bdb-flags txn-nowait) (bdb-flags txn-sync)))) (flags (or (current-flags) '())))
(lambda (db-env . args) (let ((result (bdb-txn-begin-int db-env parent (flags->value flags))))
(let-optionals args (if (integer? result)
((parent #f) (raise-bdb-condition result)
(flags #f)) (values)))))
(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 (import-lambda-definition
bdb-txn-abort-int (txn-id) bdb-txn-abort-int (txn-id)
"scsh_bdb_txn_abort") "scsh_bdb_txn_abort")
(define (bdb-abort-transaction txn-id) (define (abort-transaction txn-id)
(let ((ret-object (bdb-txn-abort-int txn-id))) (let ((result (bdb-txn-abort-int txn-id)))
(if (integer? ret-object) (if (integer? result)
(raise-bdb-condition ret-object) (raise-bdb-condition result)
ret-object))) (values))))
(import-lambda-definition (import-lambda-definition
bdb-txn-commit-int bdb-txn-commit-int
(txn-id flags) (txn-id flags)
"scsh_bdb_txn_commit") "scsh_bdb_txn_commit")
(define bdb-commit-transaction (define (commit-transaction txn-id . args)
(let ((valid-flags (let-optionals args
(list (bdb-flags txn-nosync) (bdb-flags txn-sync)))) ((flags (or (current-flags) '())))
(lambda (txn-id . args) (let ((result (bdb-txn-commit-int txn-id (flags->value))))
(let-optionals args (if (integer? result)
((flags '())) (raise-bdb-condition result)
(let ((ret-object (values)))))
(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) (define (string->byte-vector string)
(let* ((length (string-length string)) (let* ((length (string-length string))

71
scheme/packages.scm
View File

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