- support for locks

- many setters and getters for DB_ENV and DB

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, &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_GC_PROTECT_4(senv_handle, skybte, smin, sflags);
-/* s48_value scsh_bdb_env_set_data_dir(...) */
+  dbenv = scsh_extract_dbenv(senv_handle);
-/* { */
+  kbyte = s48_extract_integer(skybte);
-/*   DB_ENV->set_data_dir(); */
+  min = s48_extract_integer(smin);
-/* } */
+  flags = s48_extract_integer(sflags);
+  S48_GC_UNPROTECT();
 
-/* set the environment cryptographic key */
+  res = dbenv->txn_checkpoint(dbenv, kbyte, min, flags);
-/* s48_value scsh_bdb_env_set_encrypt(...) */
+  CHECK_BDB_RESULT_CODE(res);
-/* { */
+  return S48_FALSE;
-/*   DB_ENV->set_encrypt(); */
+}
-/* } */
 
 /* 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);
 }

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)			\

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)
+(import-lambda-definition bdb-env-create-int 
-			  "scsh_bdb_env_create")
+  (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
+    (cond
-	   (bdb-db-remove-int database-env txn-id file-name database-name
+     ((bdb-db-remove-int database-env txn-id file-name database-name
-			      (flags->value flags))))
+			 (flags->value flags))
-      (if (integer? result)
+      => raise-bdb-condition))))
-	  (raise-bdb-condition result)
-	  (values)))))
 
 (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
+    (cond
-	   (bdb-db-rename-int database-env txn-id file-name database-name
+     ((bdb-db-rename-int database-env txn-id file-name database-name
-			      new-name (flags->value flags))))
+			 new-name (flags->value flags))
-      (if (integer? result)
+      => raise-bdb-condition))))
-	  (raise-bdb-condition result)
-	  (values)))))
 
 (import-lambda-definition 
     bdb-env-open-int 
@@ -372,31 +390,25 @@
   (let-optionals args
       ((flags (or (current-flags) '()))
        (mode 0))
-    (let ((result
+    (cond
-	   (bdb-env-open-int 
+     ((bdb-env-open-int db-env home-dir (flags->value flags) mode)
-	    db-env home-dir (flags->value flags) mode)))
+      => raise-bdb-condition))))
-      (if (integer? result)
-	  (raise-bdb-condition result)
-	  (values)))))
 
 (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
+  (cond 
-	 (bdb-env-set-data-dir-int db-env dir)))
+   ((bdb-env-set-data-dir-int db-env dir)
-    (if (integer? result)
+    => raise-bdb-condition)))
-	(raise-bdb-condition result)
-	(values))))
 
 (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
+  (let ((result (bdb-env-get-data-dirs db-env)))
-	 (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
+    (cond
-	   (bdb-env-set-encrypt-int database-env password
+     ((bdb-env-set-encrypt-int database-env password
-				    (flags->value flags))))
+			       (flags->value flags))
-      (if (integer? result)
+      => raise-bdb-condition))))
-	  (raise-bdb-condition result)
-	  (values)))))
 
 (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)
+     (if (zero? error-code)
-	 (raise-bdb-condition error-code)
+	 flags
-	 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
+  (cond 
-	 (bdb-env-set-timeout-int db-env timeout #t)))
+   ((bdb-env-set-timeout-int db-env timeout #t)
-    (if (integer? result)
+    => raise-bdb-condition)))
-	(raise-bdb-condition result)
-	(values))))
 
 (define (set-database-env-transaction-timeout! db-env timeout)
-  (let ((result
+  (cond
-	 (bdb-env-set-timeout-int db-env timeout #f)))
+   ((bdb-env-set-timeout-int db-env timeout #f)
-    (if (integer? result)
+    => raise-bdb-condition)))
-	(raise-bdb-condition result)
-	(values))))
 
 (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
+  (cond
-	 (bdb-env-set-tmp-dir-int db-env dir)))
+   ((bdb-env-set-tmp-dir-int db-env dir)
-    (if (not (zero? result))
+    => raise-bdb-condition)))
-	(raise-bdb-condition result)
-	(values))))
 
 (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?)))
+  (cond 
-    (if (integer? result)
+   ((bdb-env-set-flags db-env (flags->value flags) clear?)
-	(raise-bdb-condition result)
+    => raise-bdb-condition)))
-	(values))))
 
 (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)))
+      (cond 
-	(if (integer? result)
+       ((bdb-env-close-int db-env)
-	    (raise-bdb-condition result)
+	=> raise-bdb-condition)
-	    (begin
+       (else
-	      (add-finalizer! db-env (lambda (x) x))
+	(add-finalizer! db-env (lambda (x) x))))))
-	      (values))))))
+
+(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
+    (cond
-	   (bdb-open-int db-handle db-file database-name txn-id
+     ((bdb-open-int db-handle db-file database-name txn-id
-			 (database-type-id type)
+		    (database-type-id type)
-			 (flags->value flags) mode)))
+		    (flags->value flags) mode)
-      (if (integer? result)
+      => raise-bdb-condition))))
-	  (raise-bdb-condition result)
-	  (values)))))
 
 (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
+	(cond 
-	       (bdb-close-int db-handle (flags->value flags))))
+	 ((bdb-close-int db-handle (flags->value flags))
-	  (if (integer? result)
+	  => raise-bdb-condition)
-	      (raise-bdb-condition result)
+	 (else
-	      (begin
+	  (set-database-closed?! db-handle #t))))))
-		(set-database-closed?! db-handle #t)
-		(values)))))))
 
 (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 
+    (cond 
-		   db-handle key data
+     ((bdb-put-int db-handle key data txn-id (flags->value flags))
-		   txn-id (flags->value flags))))
+      => raise-bdb-condition))))
-      (if (integer? result)
-	  (raise-bdb-condition result)
-	  (values)))))
 
 (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
+    (cond 
-	   (bdb-del-int db-handle key txn-id (flags->value flags))))
+     ((bdb-del-int db-handle key txn-id (flags->value flags))
-      (if (integer? result)
+      => raise-bdb-condition))))
-	  (raise-bdb-condition result)
-	  (values)))))
 
 (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
+    (cond 
-	   (bdb-truncate-int db-handle txn-id (flags->value flags))))
+     ((bdb-truncate-int db-handle txn-id (flags->value flags))
-      (if (integer? result)
+      => raise-bdb-condition))))
-	  (raise-bdb-condition result)
-	  result))))
 
 (import-lambda-definition 
     bdb-sync-int 
   (db-handle)
   "scsh_bdb_sync")
 
-(define (database-sync db-handle)
+(define (database-sync database)
-  (let ((result (bdb-sync-int db-handle)))
+  (cond ((bdb-sync-int database)
-    (if (integer? result)
+	 => raise-bdb-condition)))
-	(raise-bdb-condition result)
+
-	(values))))
+(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)))
-     

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
-
+     database-env-close
-     remove-database
+     database-env-fresh-locker-id
-     rename-database
+     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))