From 321045b32902678a149e5414c7df79136f4d7449 Mon Sep 17 00:00:00 2001 From: eknauel Date: Mon, 20 Sep 2004 07:03:52 +0000 Subject: [PATCH] more fixes, simplified --- c/bdb.c | 393 ++++++++++++++-------------------- c/bdb.h | 9 +- scheme/bdb.scm | 508 ++++++++++++++++++++------------------------ scheme/packages.scm | 71 ++++--- 4 files changed, 444 insertions(+), 537 deletions(-) diff --git a/c/bdb.c b/c/bdb.c index 0344c61..d425a21 100644 --- a/c/bdb.c +++ b/c/bdb.c @@ -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(2); - S48_GC_PROTECT_2(env, sflags); + S48_DECLARE_GC_PROTECT(1); + + 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(...) */ -/* { */ -/* DB_ENV->dbremove(); */ -/* } */ +/* s48_value scsh_bdb_dbremove(s48_value senv_handle, s48_value stxnid, */ +/* s48_value sfile, s48_value sdatabase, */ +/* 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 */ -/* 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,8 +463,16 @@ s48_value scsh_bdb_get(s48_value handle, s48_value skey, S48_GC_UNPROTECT(); 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 */ @@ -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); - - 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); + 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_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); diff --git a/c/bdb.h b/c/bdb.h index 2233316..e3f4a17 100644 --- a/c/bdb.h +++ b/c/bdb.h @@ -32,9 +32,9 @@ s48_value scsh_enter_dbenv(DB_ENV *h); #define CHECK_BDB_RESULT_CODE(res) \ do { \ - if (res < 0) \ + if (res > 0) \ s48_raise_os_error(res); \ - if (res > 0) \ + 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); diff --git a/scheme/bdb.scm b/scheme/bdb.scm index e85e9f5..9d175dc 100644 --- a/scheme/bdb.scm +++ b/scheme/bdb.scm @@ -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)))) - (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))))))) +(define make-database-env + (lambda args + (let-optionals args + ((flags (or (current-flags) '()))) + (let ((handle (bdb-env-create-int (flags->value flags)))) + (if (integer? handle) + (raise-bdb-condition handle) + (begin + (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) - (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)))))) +(define (database-env-open env-handle home-dir . args) + (let-optionals args + ((flags (or (current-flags) '())) + (mode 0)) + (let ((result + (bdb-env-open-int + 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)))) - (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)))))) +(define (make-database . args) + (let-optionals args + ((env (or (current-env) #f)) + (flags (or (current-flags) '()))) + (let ((handle + (bdb-create-int env (flags->value flags)))) + (if (integer? handle) + (raise-bdb-condition handle) + (begin + (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) - (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)))))) +(define (open-database db-handle db-file . args) + (let-optionals args + ((type (database-type binary-tree)) + (flags (or (current-flags) '())) + (mode 0) + (database-name #f) + (txn-id (or (current-transaction-id) #f))) + (let ((result + (bdb-open-int db-handle db-file database-name txn-id + (database-type-id type) + (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) - (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)))))) +(define (close-database db-handle . args) + (let-optionals args + ((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) - (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)))))) +(define (database-put db-handle key data . args) + (let-optionals args + ((txn-id (or (current-transaction-id) #f)) + (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) - (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)))))) +(define (database-get db-handle key . args) + (let-optionals args + ((txn-id (or (current-transaction-id) #f)) + (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) - (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)))))) +(define (database-delete-item db-handle key . args) + (let-optionals args + ((txn-id (or (current-transaction-id) #f)) + (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) - (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)))))) +(define (database-truncate db-handle . args) + (let-optionals args + ((txn-id (or (current-transaction-id) #f)) + (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) - (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)))))) +(define (begin-transaction db-env . args) + (let-optionals args + ((parent #f) + (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) - (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 (commit-transaction txn-id . args) + (let-optionals args + ((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)) diff --git a/scheme/packages.scm b/scheme/packages.scm index a314db1..a38ca29 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -1,10 +1,21 @@ (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 database-type-name @@ -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 + + make-database + open-database + close-database - 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)) + 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