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

- support for locks 

- many setters and getters for DB_ENV and DB
This commit is contained in:
eknauel 2004-09-22 15:53:38 +00:00
parent c0fc436bf3
commit ecb0244b52
4 changed files with 670 additions and 133 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

366
c/bdb.c
View File

@ -84,6 +84,13 @@ static s48_value scheme_DB_QUEUE = S48_FALSE;
static s48_value scheme_DB_RECNO = S48_FALSE;
static s48_value scheme_DB_UNKNOWN = S48_FALSE;
/* lock types */
static s48_value scheme_DB_LOCK_READ = S48_FALSE;
static s48_value scheme_DB_LOCK_WRITE = S48_FALSE;
static s48_value scheme_DB_LOCK_IWRITE = S48_FALSE;
static s48_value scheme_DB_LOCK_IREAD = S48_FALSE;
static s48_value scheme_DB_LOCK_IWR = S48_FALSE;
s48_value scsh_enter_db(DB *h)
{
s48_value rec = S48_FALSE;
@ -98,6 +105,18 @@ s48_value scsh_enter_db(DB *h)
return rec;
}
s48_value scsh_enter_lock(DB_LOCK *l)
{
s48_value rec = S48_FALSE;
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1(rec);
rec = s48_make_record(bdb_lock_record_type);
S48_RECORD_SET(rec, 0, s48_enter_integer((long) l));
S48_GC_UNPROTECT();
return rec;
}
s48_value scsh_enter_txnid(DB_TXN *txnid)
{
s48_value rec = S48_FALSE;
@ -196,7 +215,88 @@ s48_value scsh_bdb_env_close(s48_value env)
res = dbenv->close(dbenv, 0);
CHECK_BDB_RESULT_CODE(res);
return S48_TRUE;
return S48_FALSE;
}
/* acquire a locker id */
s48_value scsh_bdb_env_lock_id(s48_value senv_handle)
{
DB_ENV *dbenv;
int res;
u_int32_t idp = 0;
dbenv = scsh_extract_dbenv(senv_handle);
res = dbenv->lock_id(dbenv, &idp);
if (res > 0)
s48_raise_os_error(res);
return s48_list_2(s48_enter_integer(res),
(res == 0) ? s48_enter_integer((long) idp) : S48_FALSE);
}
/* release a locker id */
s48_value scsh_bdb_env_lock_id_free(s48_value senv_handle, s48_value slocker_id)
{
DB_ENV *dbenv;
int res;
u_int32_t locker_id;
S48_DECLARE_GC_PROTECT(2);
S48_GC_PROTECT_2(senv_handle, slocker_id);
dbenv = scsh_extract_dbenv(senv_handle);
locker_id = s48_extract_integer(slocker_id);
S48_GC_UNPROTECT();
res = dbenv->lock_id_free(dbenv, locker_id);
CHECK_BDB_RESULT_CODE(res);
return S48_FALSE;
}
/* acquire a lock */
s48_value scsh_bdb_env_lock_get(s48_value senv_handle, s48_value slocker_id,
s48_value sflags, s48_value sobject,
s48_value slock_mode)
{
DB_ENV *dbenv;
int res;
u_int32_t locker_id, flags;
DBT object;
DB_LOCK *lock;
db_lockmode_t lock_mode;
S48_DECLARE_GC_PROTECT(5);
S48_GC_PROTECT_5(senv_handle, slocker_id, sflags, sobject, slock_mode);
dbenv = scsh_extract_dbenv(senv_handle);
locker_id = s48_extract_integer(slocker_id);
flags = s48_extract_integer(sflags);
memset(&object, 0, sizeof(DBT));
scsh_extract_bytevector_as_DBT(sobject, &object);
lock_mode = s48_extract_integer(slock_mode);
S48_GC_UNPROTECT();
if ((lock = (DB_LOCK *) calloc(1, sizeof(DB_LOCK))) == NULL)
s48_raise_out_of_memory();
res = dbenv->lock_get(dbenv, locker_id, flags, &object,
lock_mode, lock);
return s48_list_2(s48_enter_integer(res),
(res == 0) ? s48_enter_integer((long) lock) : S48_FALSE);
}
/* release a lock */
s48_value scsh_bdb_env_lock_put(s48_value senv_handle, s48_value slock)
{
DB_ENV *dbenv;
int res;
DB_LOCK *lock;
S48_DECLARE_GC_PROTECT(2);
S48_GC_PROTECT_2(senv_handle, slock);
dbenv = scsh_extract_dbenv(senv_handle);
lock = scsh_extract_lock(slock);
S48_GC_UNPROTECT();
res = dbenv->lock_put(dbenv, lock);
CHECK_BDB_RESULT_CODE(res);
return S48_FALSE;
}
/* remove a database */
@ -221,8 +321,8 @@ s48_value scsh_bdb_dbremove(s48_value senv_handle, s48_value stxnid,
res = dbenv->dbremove(dbenv, txnid, file, database, flags);
CHECK_BDB_RESULT_CODE(res);
return S48_TRUE;
}
return S48_FALSE;
}
/* rename a database */
s48_value scsh_bdb_dbrename(s48_value senv_handle, s48_value stxnid,
@ -246,7 +346,7 @@ s48_value scsh_bdb_dbrename(s48_value senv_handle, s48_value stxnid,
res = dbenv->dbrename(dbenv, txnid, file, database, newname, flags);
CHECK_BDB_RESULT_CODE(res);
return S48_TRUE;
return S48_FALSE;
}
/* open an environment */
@ -269,7 +369,7 @@ s48_value scsh_bdb_env_open(s48_value env_handle, s48_value sdb_home,
res = dbenv->open(dbenv, dbhome, flags, mode);
CHECK_BDB_RESULT_CODE(res);
return S48_TRUE;
return S48_FALSE;
}
/* set path for method database files */
@ -287,7 +387,7 @@ s48_value scsh_bdb_env_set_data_dir(s48_value senv_handle, s48_value sdir)
res = dbenv->set_data_dir(dbenv, dir);
CHECK_BDB_RESULT_CODE(res);
return S48_TRUE;
return S48_FALSE;
}
s48_value scsh_bdb_env_get_data_dirs(s48_value senv_handle)
@ -360,7 +460,7 @@ s48_value scsh_bdb_env_set_timeout(s48_value senv_handle, s48_value stimeout,
res = dbenv->set_timeout(dbenv, timeout, flags);
CHECK_BDB_RESULT_CODE(res);
return S48_TRUE;
return S48_FALSE;
}
/* get timeout for locks and transactions */
@ -381,6 +481,67 @@ s48_value scsh_bdb_env_get_timeout(s48_value senv_handle, s48_value lockp)
(res == 0) ? s48_enter_integer((long) timeout) : S48_FALSE);
}
/* set a maximum number of transactions */
s48_value scsh_bdb_env_set_tx_max(s48_value senv_handle, s48_value smax)
{
DB_ENV *dbenv;
u_int32_t max;
int res;
S48_DECLARE_GC_PROTECT(2);
S48_GC_PROTECT_2(senv_handle, smax);
dbenv = scsh_extract_dbenv(senv_handle);
max = s48_extract_integer(smax);
S48_GC_UNPROTECT();
res = dbenv->set_tx_max(dbenv, max);
CHECK_BDB_RESULT_CODE(res);
return S48_FALSE;
}
/* get the maximum number of transactions */
s48_value scsh_bdb_env_get_tx_max(s48_value senv_handle)
{
DB_ENV *dbenv;
u_int32_t max = 0;
int res;
dbenv = scsh_extract_dbenv(senv_handle);
res = dbenv->get_tx_max(dbenv, &max);
return s48_list_2(s48_enter_integer(res),
(res == 0) ? s48_enter_integer(max) : S48_FALSE);
}
/* set a recovery timestamp */
s48_value scsh_bdb_env_set_tx_timestamp(s48_value senv_handle, s48_value stimestamp)
{
int res;
DB_ENV *dbenv;
time_t timestamp;
S48_DECLARE_GC_PROTECT(2);
S48_GC_PROTECT_2(senv_handle, stimestamp);
dbenv = scsh_extract_dbenv(senv_handle);
timestamp = (time_t) s48_extract_integer(stimestamp);
S48_GC_UNPROTECT();
res = dbenv->set_tx_timestamp(dbenv, &timestamp);
CHECK_BDB_RESULT_CODE(res);
return S48_FALSE;
}
/* get a recovery timestamp */
s48_value scsh_bdb_env_get_tx_timestamp(s48_value senv_handle)
{
DB_ENV *dbenv;
time_t timestamp;
int res;
dbenv = scsh_extract_dbenv(senv_handle);
res = dbenv->get_tx_timestamp(dbenv, &timestamp);
return s48_list_2(s48_enter_integer(res),
(res == 0) ? s48_enter_integer(timestamp) : S48_FALSE);
}
/* set tmp dir */
s48_value scsh_bdb_env_set_tmp_dir(s48_value senv_handle, s48_value sdir)
{
@ -395,7 +556,8 @@ s48_value scsh_bdb_env_set_tmp_dir(s48_value senv_handle, s48_value sdir)
S48_GC_UNPROTECT();
res = dbenv->set_tmp_dir(dbenv, dir);
return s48_enter_integer(res);
CHECK_BDB_RESULT_CODE(res);
return S48_FALSE;
}
/* get tmp dir */
@ -455,7 +617,6 @@ s48_value scsh_bdb_env_remove(s48_value db_home, s48_value sflags)
S48_GC_PROTECT_2(db_home, sflags);
dbhome = s48_extract_string(db_home);
flags = s48_extract_integer(sflags);
S48_GC_UNPROTECT();
res = dbenv->remove(dbenv, dbhome, flags);
@ -463,19 +624,26 @@ s48_value scsh_bdb_env_remove(s48_value db_home, s48_value sflags)
return S48_TRUE;
}
/* environment configuration */
/* checkpoint the transaction subsystem */
s48_value scsh_bdb_env_txn_checkpoint(s48_value senv_handle, s48_value skybte,
s48_value smin, s48_value sflags)
{
DB_ENV *dbenv;
int res;
u_int32_t kbyte, min, flags;
S48_DECLARE_GC_PROTECT(4);
/* set the environment data directory */
/* s48_value scsh_bdb_env_set_data_dir(...) */
/* { */
/* DB_ENV->set_data_dir(); */
/* } */
S48_GC_PROTECT_4(senv_handle, skybte, smin, sflags);
dbenv = scsh_extract_dbenv(senv_handle);
kbyte = s48_extract_integer(skybte);
min = s48_extract_integer(smin);
flags = s48_extract_integer(sflags);
S48_GC_UNPROTECT();
/* set the environment cryptographic key */
/* s48_value scsh_bdb_env_set_encrypt(...) */
/* { */
/* DB_ENV->set_encrypt(); */
/* } */
res = dbenv->txn_checkpoint(dbenv, kbyte, min, flags);
CHECK_BDB_RESULT_CODE(res);
return S48_FALSE;
}
/* create DB - returns dbp handle */
s48_value scsh_bdb_create(s48_value env, s48_value sflags)
@ -523,7 +691,7 @@ s48_value scsh_bdb_open(s48_value db, s48_value sfile, s48_value sdatabase,
res = dbp->open(dbp, txnid, dbfile, database, type, flags, mode);
CHECK_BDB_RESULT_CODE(res);
return S48_TRUE;
return S48_FALSE;
}
/* close DB */
@ -541,7 +709,7 @@ s48_value scsh_bdb_close(s48_value db, s48_value sflags)
res = dbp->close(dbp, flags);
CHECK_BDB_RESULT_CODE(res);
return S48_TRUE;
return S48_FALSE;
}
s48_value scsh_bdb_truncate(s48_value db, s48_value stxnid, s48_value sflags)
@ -561,7 +729,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_enter_integer(res);
return S48_FALSE;
}
s48_value scsh_bdb_sync(s48_value db)
@ -576,7 +744,7 @@ s48_value scsh_bdb_sync(s48_value db)
res = dbp->sync(dbp, 0);
CHECK_BDB_RESULT_CODE(res);
return S48_TRUE;
return S48_FALSE;
}
/* DBT as byte vectors */
@ -605,6 +773,125 @@ void scsh_extract_bytevector_as_DBT(s48_value bytevector, DBT* dt)
/* DBT operations */
/* set the database cryptographic key */
s48_value scsh_bdb_set_encrypt(s48_value sdatabase, s48_value spasswd,
s48_value sflags)
{
DB *db;
char *passwd;
int res;
u_int32_t flags;
S48_DECLARE_GC_PROTECT(3);
S48_GC_PROTECT_3(sdatabase, spasswd, sflags);
db = scsh_extract_db(sdatabase);
flags = s48_extract_integer(sflags);
passwd = s48_extract_string(spasswd);
res = db->set_encrypt(db, passwd, flags);
memset(&passwd, 0, S48_STRING_LENGTH(spasswd));
S48_GC_UNPROTECT();
CHECK_BDB_RESULT_CODE(res);
return S48_FALSE;
}
/* get the database cryptographic flags */
s48_value scsh_bdb_get_encrypt_flags(s48_value sdatabase)
{
DB *db;
int res;
u_int32_t flags = 0;
db = scsh_extract_db(sdatabase);
res = db->get_encrypt_flags(db, &flags);
return s48_list_2(s48_enter_integer(res),
(res == 0) ? s48_enter_integer(flags) : S48_FALSE);
}
/* general database configuration */
s48_value scsh_bdb_set_flags(s48_value sdatabase, s48_value sflags)
{
DB *db;
int res;
u_int32_t flags;
S48_DECLARE_GC_PROTECT(2);
S48_GC_PROTECT_2(sdatabase, sflags);
db = scsh_extract_db(sdatabase);
flags = s48_extract_integer(sflags);
S48_GC_UNPROTECT();
res = db->set_flags(db, flags);
CHECK_BDB_RESULT_CODE(res);
return S48_FALSE;
}
s48_value scsh_bdb_get_flags(s48_value sdatabase)
{
DB *db;
int res;
u_int32_t flags;
db = scsh_extract_db(sdatabase);
res = db->get_flags(db, &flags);
return s48_list_2(s48_enter_integer(res),
(res == 0) ? s48_enter_integer(flags) : S48_FALSE);
}
s48_value scsh_bdb_set_lorder(s48_value sdatabase, s48_value sbig_endian_p)
{
DB *db;
int res;
S48_DECLARE_GC_PROTECT(2);
S48_GC_PROTECT_2(sdatabase, sbig_endian_p);
db = scsh_extract_db(sdatabase);
res = db->set_lorder(db, (sbig_endian_p == S48_TRUE) ? 4321 : 1234);
S48_GC_UNPROTECT();
CHECK_BDB_RESULT_CODE(res);
return S48_FALSE;
}
s48_value scsh_bdb_get_lorder(s48_value sdatabase)
{
DB *db;
int res, lorder;
db = scsh_extract_db(sdatabase);
res = db->get_lorder(db, &lorder);
return s48_list_2(s48_enter_integer(res),
(res == 0) ? ((lorder == 4321) ? S48_TRUE : S48_FALSE)
: S48_UNSPECIFIC);
}
s48_value scsh_bdb_set_pagesize(s48_value sdatabase, s48_value spagesize)
{
DB *db;
u_int32_t pagesize;
int res;
S48_DECLARE_GC_PROTECT(2);
S48_GC_PROTECT_2(sdatabase, spagesize);
db = scsh_extract_db(sdatabase);
pagesize = s48_extract_integer(spagesize);
S48_GC_UNPROTECT();
res = db->set_pagesize(db, pagesize);
CHECK_BDB_RESULT_CODE(res);
return S48_FALSE;
}
s48_value scsh_bdb_get_pagesize(s48_value sdatabase)
{
DB *db;
u_int32_t pagesize = 0;
int res;
db = scsh_extract_db(sdatabase);
res = db->get_pagesize(db, &pagesize);
return s48_list_2(s48_enter_integer(res),
(res == 0) ? s48_enter_integer(pagesize) : S48_FALSE);
}
/* Put key and data DBT's in DB */
s48_value scsh_bdb_put(s48_value db, s48_value skey, s48_value sdata,
s48_value stxnid, s48_value sflags)
@ -630,7 +917,7 @@ s48_value scsh_bdb_put(s48_value db, s48_value skey, s48_value sdata,
res = dbp->put(dbp, txnid, &key, &data, flags);
S48_GC_UNPROTECT();
CHECK_BDB_RESULT_CODE(res);
return S48_TRUE;
return S48_FALSE;
}
/* Get DBT to corresponding key */
@ -690,7 +977,7 @@ s48_value scsh_bdb_del(s48_value handle, s48_value skey,
S48_GC_UNPROTECT();
res = dbp->del(dbp, txnid, &key, flags);
CHECK_BDB_RESULT_CODE(res);
return S48_TRUE;
return S48_FALSE;
}
s48_value scsh_bdb_create_cursor(s48_value handle, s48_value stxnid,
@ -819,6 +1106,9 @@ void scsh_init_bdb_bindings(void)
S48_GC_PROTECT_GLOBAL(bdb_env_record_type);
bdb_env_record_type = s48_get_imported_binding("bdb-env");
S48_GC_PROTECT_GLOBAL(bdb_lock_record_type);
bdb_lock_record_type = s48_get_imported_binding("bdb-lock");
S48_GC_PROTECT_GLOBAL(bdb_mpoolfile_record_type);
bdb_mpoolfile_record_type = s48_get_imported_binding("bdb-mpoolfile");
@ -911,6 +1201,13 @@ void scsh_init_bdb_bindings(void)
ENTER_INTEGER_CONSTANT(scheme_DB_SECONDARY_BAD, DB_SECONDARY_BAD);
ENTER_INTEGER_CONSTANT(scheme_DB_VERIFY_BAD, DB_VERIFY_BAD);
/* lock modes */
ENTER_INTEGER_CONSTANT(scheme_DB_LOCK_READ, DB_LOCK_READ);
ENTER_INTEGER_CONSTANT(scheme_DB_LOCK_WRITE, DB_LOCK_WRITE);
ENTER_INTEGER_CONSTANT(scheme_DB_LOCK_IWRITE, DB_LOCK_IWRITE);
ENTER_INTEGER_CONSTANT(scheme_DB_LOCK_IREAD, DB_LOCK_IREAD);
ENTER_INTEGER_CONSTANT(scheme_DB_LOCK_IWR, DB_LOCK_IWR);
/* export functions to scheme */
S48_EXPORT_FUNCTION(scsh_bdb_create);
S48_EXPORT_FUNCTION(scsh_bdb_open);
@ -929,11 +1226,18 @@ void scsh_init_bdb_bindings(void)
S48_EXPORT_FUNCTION(scsh_bdb_env_get_timeout);
S48_EXPORT_FUNCTION(scsh_bdb_env_set_tmp_dir);
S48_EXPORT_FUNCTION(scsh_bdb_env_get_tmp_dir);
S48_EXPORT_FUNCTION(scsh_bdb_env_set_tx_max);
S48_EXPORT_FUNCTION(scsh_bdb_env_get_tx_max);
S48_EXPORT_FUNCTION(scsh_bdb_env_set_tx_timestamp);
S48_EXPORT_FUNCTION(scsh_bdb_env_get_tx_timestamp);
S48_EXPORT_FUNCTION(scsh_bdb_env_set_flags);
S48_EXPORT_FUNCTION(scsh_bdb_env_get_flags);
S48_EXPORT_FUNCTION(scsh_bdb_env_open);
S48_EXPORT_FUNCTION(scsh_bdb_env_close);
S48_EXPORT_FUNCTION(scsh_bdb_env_lock_get);
S48_EXPORT_FUNCTION(scsh_bdb_env_lock_put);
S48_EXPORT_FUNCTION(scsh_bdb_env_remove);
S48_EXPORT_FUNCTION(scsh_bdb_env_txn_checkpoint);
S48_EXPORT_FUNCTION(scsh_bdb_truncate);
S48_EXPORT_FUNCTION(scsh_bdb_sync);
S48_EXPORT_FUNCTION(scsh_bdb_create_cursor);
@ -942,4 +1246,14 @@ void scsh_init_bdb_bindings(void)
S48_EXPORT_FUNCTION(scsh_bdb_txn_begin);
S48_EXPORT_FUNCTION(scsh_bdb_txn_abort);
S48_EXPORT_FUNCTION(scsh_bdb_txn_commit);
S48_EXPORT_FUNCTION(scsh_bdb_set_encrypt);
S48_EXPORT_FUNCTION(scsh_bdb_get_encrypt_flags);
S48_EXPORT_FUNCTION(scsh_bdb_set_flags);
S48_EXPORT_FUNCTION(scsh_bdb_get_flags);
S48_EXPORT_FUNCTION(scsh_bdb_set_lorder);
S48_EXPORT_FUNCTION(scsh_bdb_get_lorder);
S48_EXPORT_FUNCTION(scsh_bdb_set_pagesize);
S48_EXPORT_FUNCTION(scsh_bdb_get_pagesize);
S48_EXPORT_FUNCTION(scsh_bdb_env_lock_id);
S48_EXPORT_FUNCTION(scsh_bdb_env_lock_id_free);
}

8
c/bdb.h
View File

@ -9,6 +9,7 @@
/* record types */
static s48_value bdb_db_record_type = S48_FALSE;
static s48_value bdb_env_record_type = S48_FALSE;
static s48_value bdb_lock_record_type = S48_FALSE;
static s48_value bdb_mpoolfile_record_type = S48_FALSE;
static s48_value bdb_txn_record_type = S48_FALSE;
static s48_value bdb_dbc_record_type = S48_FALSE;
@ -30,6 +31,13 @@ s48_value scsh_enter_dbenv(DB_ENV *h);
#define scsh_extract_dbenv(x) \
((DB_ENV *) s48_extract_integer(S48_RECORD_REF(x, 0)))
s48_value scsh_enter_lock(DB_LOCK *l);
#define scsh_extract_lock(x) \
((DB_LOCK *) s48_extract_integer(S48_RECORD_REF(x, 0)))
s48_value scsh_enter_DBT_as_bytevector(DBT* dt);
void scsh_extract_bytevector_as_DBT(s48_value bytevector, DBT* dt);
#define CHECK_BDB_RESULT_CODE(res) \
do { \
if (res > 0) \

388
scheme/bdb.scm
View File

@ -114,6 +114,20 @@
(txn-nowait (lookup-shared-value "scheme_DB_TXN_NOWAIT"))
(txn-sync (lookup-shared-value "scheme_DB_TXN_SYNC"))))
(define-finite-type lock-mode :lock-mode
(id)
lock-mode-object?
lock-mode-elements
lock-mode-name
lock-mode-index
(id lock-mode-value)
((read-shared (lookup-shared-value "scheme_DB_LOCK_READ"))
(write-exclusive (lookup-shared-value "scheme_DB_LOCK_WRITE"))
(intention-to-write (lookup-shared-value "scheme_DB_LOCK_IWRITE"))
(intention-to-read (lookup-shared-value "scheme_DB_LOCK_IREAD"))
(intention-to-read-and-write
(lookup-shared-value "scheme_DB_LOCK_IWR"))))
(define-finite-type return-code :return-code
(id)
return-code-object?
@ -260,6 +274,13 @@
(define-exported-binding "bdb-db" :database)
(define-record-type database-lock :database-lock
(make-database-lock c-pointer)
database-lock?
(c-pointer database-lock-c-pointer))
(define-exported-binding "bdb-lock" :database-lock)
;;; DB environement handle : DB_ENV
(define-record-type database-env :database-env
(make-database-env c-pointer weak-list)
@ -317,8 +338,9 @@
(define cursor-finalizer bdb-cursor-close-int)
(import-lambda-definition bdb-env-create-int (flags)
"scsh_bdb_env_create")
(import-lambda-definition bdb-env-create-int
(flags)
"scsh_bdb_env_create")
(define make-database-env
(lambda args
@ -339,12 +361,10 @@
(let-optionals args
((txn-id (or (current-transaction-id) '()))
(flags (or (current-flags) '())))
(let ((result
(bdb-db-remove-int database-env txn-id file-name database-name
(flags->value flags))))
(if (integer? result)
(raise-bdb-condition result)
(values)))))
(cond
((bdb-db-remove-int database-env txn-id file-name database-name
(flags->value flags))
=> raise-bdb-condition))))
(import-lambda-definition bdb-db-rename-int
(env-handle txn-id file database new-name flags)
@ -355,12 +375,10 @@
(let-optionals args
((txn-id (or (current-transaction-id) '()))
(flags (or (current-flags) '())))
(let ((result
(bdb-db-rename-int database-env txn-id file-name database-name
new-name (flags->value flags))))
(if (integer? result)
(raise-bdb-condition result)
(values)))))
(cond
((bdb-db-rename-int database-env txn-id file-name database-name
new-name (flags->value flags))
=> raise-bdb-condition))))
(import-lambda-definition
bdb-env-open-int
@ -372,31 +390,25 @@
(let-optionals args
((flags (or (current-flags) '()))
(mode 0))
(let ((result
(bdb-env-open-int
db-env home-dir (flags->value flags) mode)))
(if (integer? result)
(raise-bdb-condition result)
(values)))))
(cond
((bdb-env-open-int db-env home-dir (flags->value flags) mode)
=> raise-bdb-condition))))
(import-lambda-definition bdb-env-set-data-dir-int
(env-handle dir)
"scsh_bdb_env_set_data_dir")
(define (set-database-env-data-dir! db-env dir)
(let ((result
(bdb-env-set-data-dir-int db-env dir)))
(if (integer? result)
(raise-bdb-condition result)
(values))))
(cond
((bdb-env-set-data-dir-int db-env dir)
=> raise-bdb-condition)))
(import-lambda-definition bdb-env-get-data-dirs
(env-handle)
"scsh_bdb_env_get_data_dirs")
(define (database-env-data-dirs db-env)
(let ((result
(bdb-env-get-data-dirs db-env)))
(let ((result (bdb-env-get-data-dirs db-env)))
(if (integer? result)
(raise-bdb-condition result)
result)))
@ -408,44 +420,37 @@
(define (set-database-env-encrypt! database-env password . args)
(let-optionals args
((flags (or (current-flags) '())))
(let ((result
(bdb-env-set-encrypt-int database-env password
(flags->value flags))))
(if (integer? result)
(raise-bdb-condition result)
(values)))))
(cond
((bdb-env-set-encrypt-int database-env password
(flags->value flags))
=> raise-bdb-condition))))
(import-lambda-definition bdb-env-get-encrypt-flags-int
(env-handle)
"scsh_bdb_env_get_encrypt_flags")
;; FIXME
(define (database-env-encrypt-flags database-env)
(call-with-values
(lambda ()
(apply values (bdb-env-get-encrypt-flags-int database-env)))
(lambda (error-code flags)
(if (< error-code 0)
(raise-bdb-condition error-code)
flags))))
(if (zero? error-code)
flags
(raise-bdb-condition error-code)))))
(import-lambda-definition bdb-env-set-timeout-int
(env-handle timeout lock?)
"scsh_bdb_env_set_timeout")
(define (set-database-env-lock-timeout! db-env timeout)
(let ((result
(bdb-env-set-timeout-int db-env timeout #t)))
(if (integer? result)
(raise-bdb-condition result)
(values))))
(cond
((bdb-env-set-timeout-int db-env timeout #t)
=> raise-bdb-condition)))
(define (set-database-env-transaction-timeout! db-env timeout)
(let ((result
(bdb-env-set-timeout-int db-env timeout #f)))
(if (integer? result)
(raise-bdb-condition result)
(values))))
(cond
((bdb-env-set-timeout-int db-env timeout #f)
=> raise-bdb-condition)))
(import-lambda-definition bdb-env-get-timeout-int
(env-handle lockp)
@ -474,11 +479,9 @@
"scsh_bdb_env_set_tmp_dir")
(define (set-database-env-tmp-dir! db-env dir)
(let ((result
(bdb-env-set-tmp-dir-int db-env dir)))
(if (not (zero? result))
(raise-bdb-condition result)
(values))))
(cond
((bdb-env-set-tmp-dir-int db-env dir)
=> raise-bdb-condition)))
(import-lambda-definition bdb-env-get-tmp-dir-int
(env-handle)
@ -493,15 +496,56 @@
tmp-dir
(raise-bdb-condition error-code)))))
(import-lambda-definition bdb-env-set-tx-max
(env-handle max)
"scsh_bdb_env_set_tx_max")
(define (set-database-env-max-transactions! db-env max)
(cond ((bdb-env-set-tx-max db-env max)
=> raise-bdb-condition)))
(import-lambda-definition bdb-env-get-tx-max
(env-handle)
"scsh_bdb_env_get_tx_max")
(define (database-env-max-transactions db-env)
(call-with-values
(lambda ()
(apply values (bdb-env-get-tx-max db-env)))
(lambda (error-code max)
(if (zero? error-code)
max
(raise-bdb-condition error-code)))))
(import-lambda-definition bdb-env-set-tx-timestamp
(env-handle timestamp)
"scsh_bdb_env_set_tx_timestamp")
(define (set-database-env-transaction-timestamp! db-env timestamp)
(cond ((bdb-env-set-tx-timestamp db-env timestamp)
=> raise-bdb-condition)))
(import-lambda-definition bdb-env-get-tx-timestamp
(env-handle)
"scsh_bdb_env_get_tx_timestamp")
(define (database-env-transaction-timestamp db-env)
(call-with-values
(lambda ()
(apply values (bdb-env-get-tx-timestamp db-env)))
(lambda (error-code timestamp)
(if (zero? error-code)
timestamp
(raise-bdb-condition error-code)))))
(import-lambda-definition bdb-env-set-flags
(env-handle flags clear?)
"scsh_bdb_env_set_flags")
(define (modify-database-env-flags! db-env flags clear?)
(let ((result (bdb-env-set-flags db-env (flags->value flags) clear?)))
(if (integer? result)
(raise-bdb-condition result)
(values))))
(cond
((bdb-env-set-flags db-env (flags->value flags) clear?)
=> raise-bdb-condition)))
(define (set-database-env-flags! db-env flags)
(modify-database-env-flags! db-env flags #f))
@ -529,12 +573,80 @@
(define (database-env-close db-env)
(if (null? (database-env-weak-list db-env))
(let ((result (bdb-env-close-int db-env)))
(if (integer? result)
(raise-bdb-condition result)
(begin
(add-finalizer! db-env (lambda (x) x))
(values))))))
(cond
((bdb-env-close-int db-env)
=> raise-bdb-condition)
(else
(add-finalizer! db-env (lambda (x) x))))))
(import-lambda-definition bdb-env-lock-id
(env-handle)
"scsh_bdb_env_lock_id")
(define (database-env-fresh-locker-id db-env)
(call-with-values
(lambda ()
(apply values (bdb-env-lock-id db-env)))
(lambda (error-code locker-id)
(if (zero? error-code)
locker-id
(raise-bdb-condition error-code)))))
(import-lambda-definition bdb-env-locker-id-free
(env-handler locker-id)
"scsh_bdb_env_lock_id_free")
(define (database-env-free-locker-id db-env locker-id)
(cond
((bdb-env-locker-id-free db-env locker-id)
=> raise-bdb-condition)))
(import-lambda-definition bdb-env-lock-get
(env-handle locker-id flags object mode)
"scsh_bdb_env_lock_get")
(define (database-env-get-lock db-env locker-id object lock-mode . args)
(let-optionals args
((flags (or (current-flags) '())))
(call-with-values
(lambda ()
(receive (rport wport)
(pipe)
(fork
(lambda ()
(write (bdb-env-lock-get db-env locker-id (flags->value flags)
object (lock-mode-value lock-mode))
wport)))
(apply values (read rport))))
(lambda (error-code lock-pointer)
(cond
((= error-code (return-code-value (return-code lock-deadlock)))
(return-code lock-deadlock))
((= error-code (return-code-value (return-code lock-not-granted)))
(return-code lock-not-granted))
((zero? error-code)
(make-database-lock lock-pointer))
(else
(raise-bdb-condition error-code)))))))
(import-lambda-definition bdb-env-lock-put
(env-handle lock)
"scsh_bdb_env_lock_put")
(define (database-env-put-lock db-env lock)
(cond ((bdb-env-lock-put db-env lock)
=> raise-bdb-condition)))
(import-lambda-definition bdb-txn-checkpoint
(env-handle kbyte min flags)
"scsh_bdb_env_txn_checkpoint")
(define (set-database-env-transaction-checkpoint! db-env kbyte min . args)
(let-optionals args
((flags (or (current-flags) '())))
(cond
((bdb-txn-checkpoint db-env kbyte min (flags->value flags))
=> raise-bdb-condition))))
(import-lambda-definition
bdb-env-remove-int
@ -581,26 +693,22 @@
(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)))))
(cond
((bdb-open-int db-handle db-file database-name txn-id
(database-type-id type)
(flags->value flags) mode)
=> raise-bdb-condition))))
(define (close-database db-handle . args)
(let-optionals args
((flags (or (current-flags) '())))
(if (and (not (database-closed? db-handle))
(null? (database-weak-list db-handle)))
(let ((result
(bdb-close-int db-handle (flags->value flags))))
(if (integer? result)
(raise-bdb-condition result)
(begin
(set-database-closed?! db-handle #t)
(values)))))))
(cond
((bdb-close-int db-handle (flags->value flags))
=> raise-bdb-condition)
(else
(set-database-closed?! db-handle #t))))))
(import-lambda-definition
bdb-put-int
@ -611,12 +719,9 @@
(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)))))
(cond
((bdb-put-int db-handle key data txn-id (flags->value flags))
=> raise-bdb-condition))))
(import-lambda-definition
bdb-get-int
@ -644,11 +749,9 @@
(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)))))
(cond
((bdb-del-int db-handle key txn-id (flags->value flags))
=> raise-bdb-condition))))
(import-lambda-definition
bdb-truncate-int
@ -659,22 +762,112 @@
(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))))
(cond
((bdb-truncate-int db-handle txn-id (flags->value flags))
=> raise-bdb-condition))))
(import-lambda-definition
bdb-sync-int
(db-handle)
"scsh_bdb_sync")
(define (database-sync db-handle)
(let ((result (bdb-sync-int db-handle)))
(if (integer? result)
(raise-bdb-condition result)
(values))))
(define (database-sync database)
(cond ((bdb-sync-int database)
=> raise-bdb-condition)))
(import-lambda-definition bdb-set-encrypt
(database password flags)
"scsh_bdb_set_encrypt")
(define (set-database-encrypt! database password . args)
(let-optionals args
((flags (or (current-flags) '())))
(let ((result
(bdb-set-encrypt database password (flags->value flags))))
(if (integer? result)
(raise-bdb-condition result)
(values)))))
;; retest
(import-lambda-definition bdb-get-encrypt-flags
(database)
"scsh_bdb_get_encrypt_flags")
(define (database-encrypt-flags database)
(call-with-values
(lambda ()
(apply values (bdb-get-encrypt-flags database)))
(lambda (error-code flags)
(if (zero? error-code)
flags
(raise-bdb-condition error-code)))))
(import-lambda-definition bdb-set-flags
(database flags)
"scsh_bdb_set_flags")
(define (set-database-flags! database flags)
(cond
((bdb-set-flags database (flags->value flags))
=> raise-bdb-condition)))
(import-lambda-definition bdb-get-flags
(database)
"scsh_bdb_get_flags")
(define (database-flags database)
(call-with-values
(lambda ()
(apply values (bdb-get-flags database)))
(lambda (error-code flags)
(if (zero? error-code)
flags
(raise-bdb-condition error-code)))))
(import-lambda-definition bdb-set-lorder
(database big-endian?)
"scsh_bdb_set_lorder")
(define (set-database-byte-order! database use-big-endian?)
(cond ((bdb-set-lorder database use-big-endian?)
=> raise-bdb-condition)))
(import-lambda-definition bdb-get-lorder
(database)
"scsh_bdb_get_lorder")
(define (database-big-endian? database)
(call-with-values
(lambda ()
(apply values (bdb-get-lorder database)))
(lambda (error-code big-endian?)
(if (zero? error-code)
big-endian?
(raise-bdb-condition error-code)))))
(define (database-little-endian? database)
(not (database-big-endian? database)))
(import-lambda-definition bdb-set-pagesize
(database pagesize)
"scsh_bdb_set_pagesize")
(define (set-database-page-size! database page-size)
(cond
((bdb-set-pagesize database page-size)
=> raise-bdb-condition)))
(import-lambda-definition bdb-get-pagesize
(database)
"scsh_bdb_get_pagesize")
(define (database-page-size database)
(call-with-values
(lambda ()
(apply values (bdb-get-pagesize database)))
(lambda (error-code page-size)
(if (zero? error-code)
page-size
(raise-bdb-condition error-code)))))
(import-lambda-definition
bdb-create-cursor-int
@ -781,4 +974,3 @@
(let ((port (make-string-input-port
(byte-vector->string byte-vector))))
(read port)))

41
scheme/packages.scm
View File

@ -11,6 +11,11 @@
flag-name
(flag :syntax)
lock-mode-object?
lock-mode-elements
lock-mode-name
(lock-mode :syntax)
return-code-object?
return-code-elements
return-code-name
@ -36,8 +41,9 @@
cursor?
make-database-env
remove-database
rename-database
database-env-open
database-env-close
set-database-env-data-dir!
database-env-data-dirs
set-database-env-encrypt!
@ -48,26 +54,41 @@
database-env-transaction-timeout
set-database-env-tmp-dir!
database-env-tmp-dir
set-database-env-max-transactions!
database-env-max-transactions
set-database-env-transaction-timeout!
database-env-transaction-timeout
set-database-env-flags!
clear-database-env-flags!
database-env-flags
remove-database
rename-database
database-env-close
database-env-fresh-locker-id
database-env-free-locker-id
database-env-get-lock
database-env-put-lock
set-database-env-transaction-checkpoint!
make-database
open-database
close-database
database-put
database-get
database-delete-item
database-truncate
database-sync
set-database-encrypt!
database-encrypt-flags
set-database-flags!
database-flags
set-database-byte-order!
database-big-endian?
database-little-endian?
set-database-page-size!
database-page-size
make-cursor
database-get-via-cursor
begin-transaction
abort-transaction
commit-transaction
@ -81,6 +102,7 @@
(define-structure berkeley-db berkeley-db-interface
(open scheme
srfi-1
srfi-8
srfi-34
srfi-35
fluids
@ -92,6 +114,7 @@
bitwise
define-record-types
finite-types
external-calls)
external-calls
(subset scsh-level-0 (fork pipe)))
(files bdb))