diff --git a/c/bdb.c b/c/bdb.c index 1b02d40..8115b37 100644 --- a/c/bdb.c +++ b/c/bdb.c @@ -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, ×tamp); + 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, ×tamp); + 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); } diff --git a/c/bdb.h b/c/bdb.h index e3f4a17..b41ec92 100644 --- a/c/bdb.h +++ b/c/bdb.h @@ -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) \ diff --git a/scheme/bdb.scm b/scheme/bdb.scm index 44b9534..21b16f2 100644 --- a/scheme/bdb.scm +++ b/scheme/bdb.scm @@ -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))) - diff --git a/scheme/packages.scm b/scheme/packages.scm index 20c5de8..0898401 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -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)) \ No newline at end of file