- added missing flags

- added non-blocking versions for blocking calls to berkeley-db
- small fixes
- better support for cursors

scheme/bdb.scm

@@ -51,6 +51,13 @@
        (commit-transaction (current-transaction-id)))))
 
 ;; constants
+
+(define (berkeley-db-version)
+  (lookup-shared-value "scheme_DB_VERSION"))
+
+(define (berkeley-db-version-string)
+  (lookup-shared-value "scheme_DB_VERSION_VERBOSE"))
+
 (define-finite-type flag :flag
   (id)
   flag-object?
@@ -112,7 +119,37 @@
    (multiple-key	(lookup-shared-value "scheme_DB_MULTIPLE_KEY"))
    (txn-nosync		(lookup-shared-value "scheme_DB_TXN_NOSYNC"))
    (txn-nowait		(lookup-shared-value "scheme_DB_TXN_NOWAIT"))
-   (txn-sync		(lookup-shared-value "scheme_DB_TXN_SYNC"))))
+   (txn-sync		(lookup-shared-value "scheme_DB_TXN_SYNC"))
+   (lock-nowait		(lookup-shared-value "scheme_DB_LOCK_NOWAIT"))
+   (encrypt-aes		(lookup-shared-value "scheme_DB_ENCRYPT_AES"))
+   (cdb-alldb		(lookup-shared-value "scheme_DB_CDB_ALLDB"))
+   (direct-db		(lookup-shared-value "scheme_DB_DIRECT_DB"))
+   (direct-log		(lookup-shared-value "scheme_DB_DIRECT_LOG"))
+   (log-autoremove	(lookup-shared-value "scheme_DB_LOG_AUTOREMOVE"))
+   (no-locking		(lookup-shared-value "scheme_DB_NOLOCKING"))
+   (no-panic		(lookup-shared-value "scheme_DB_NOPANIC"))
+   (overwrite		(lookup-shared-value "scheme_DB_OVERWRITE"))
+   (panic-environment	(lookup-shared-value "scheme_DB_PANIC_ENVIRONMENT"))
+   (region-init		(lookup-shared-value "scheme_DB_REGION_INIT"))
+   (time-not-granted	(lookup-shared-value "scheme_DB_TIME_NOTGRANTED"))
+   (transaction-not-durable 
+			(lookup-shared-value "scheme_DB_TXN_NOT_DURABLE"))
+   (transaction-write-no-sync 
+			(lookup-shared-value "scheme_DB_TXN_NOSYNC"))
+   (force		(lookup-shared-value "scheme_DB_FORCE"))
+   (checksum		(lookup-shared-value "scheme_DB_CHKSUM"))
+   (encrypt		(lookup-shared-value "scheme_DB_ENCRYPT"))
+   (duplicate-keys	(lookup-shared-value "scheme_DB_DUP"))
+   (duplicate-keys-sort	(lookup-shared-value "scheme_DB_DUPSORT"))
+   (record-numbers	(lookup-shared-value "scheme_DB_RECNUM"))
+   (no-reverse-splits	(lookup-shared-value "scheme_DB_REVSPLITOFF"))
+   (renumber		(lookup-shared-value "scheme_DB_RENUMBER"))
+   (snapshot		(lookup-shared-value "scheme_DB_SNAPSHOT"))
+   (prev-no-duplicates	(lookup-shared-value "scheme_DB_PREV_NODUP"))
+   (after		(lookup-shared-value "scheme_DB_AFTER"))
+   (before		(lookup-shared-value "scheme_DB_BEFORE"))
+   (key-first		(lookup-shared-value "scheme_DB_KEYFIRST"))
+   (key-last		(lookup-shared-value "scheme_DB_KEYLAST"))))
 
 (define-finite-type lock-mode :lock-mode
   (id)
@@ -257,8 +294,7 @@
   (set-database-weak-list!
    db (filter-collected (database-weak-list db))))
 
-(import-lambda-definition 
+(import-lambda-definition bdb-close-int 
-    bdb-close-int 
   (db-handle flags) 
   "scsh_bdb_close")
 
@@ -366,6 +402,12 @@
 			 (flags->value flags))
       => raise-bdb-condition))))
 
+(define (remove-database/fork . args)
+  (wait (fork
+	 (lambda ()
+	   (apply remove-database args))))
+  (values))
+
 (import-lambda-definition bdb-db-rename-int
   (env-handle txn-id file database new-name flags)
   "scsh_bdb_dbrename")
@@ -380,8 +422,13 @@
 			 new-name (flags->value flags))
       => raise-bdb-condition))))
 
-(import-lambda-definition 
+(define (rename-database/fork args)
-    bdb-env-open-int 
+  (wait (fork
+	 (lambda ()
+	   (apply rename-database args))))
+  (values))
+
+(import-lambda-definition bdb-env-open-int 
   (env-handle db-home flags mode)
   "scsh_bdb_env_open")
 
@@ -566,8 +613,7 @@
 	 flags
 	 (raise-bdb-condition error-code)))))
 
-(import-lambda-definition 
+(import-lambda-definition bdb-env-close-int 
-    bdb-env-close-int 
   (env-handle)
   "scsh_bdb_env_close")
 
@@ -612,11 +658,12 @@
      (lambda ()
        (receive (rport wport) 
 	   (pipe)
-	 (fork
+	 (wait 
-	  (lambda ()
+	  (fork
-	    (write (bdb-env-lock-get db-env locker-id (flags->value flags)
+	   (lambda ()
-				     object (lock-mode-value lock-mode))
+	     (write (bdb-env-lock-get db-env locker-id (flags->value flags)
-		   wport)))
+				      object (lock-mode-value lock-mode))
+		    wport))))
 	 (apply values (read rport))))
      (lambda (error-code lock-pointer)
        (cond
@@ -648,8 +695,7 @@
      ((bdb-txn-checkpoint db-env kbyte min (flags->value flags))
       => raise-bdb-condition))))
 
-(import-lambda-definition 
+(import-lambda-definition bdb-env-remove-int 
-    bdb-env-remove-int 
   (db-home flags)
   "scsh_bdb_env_remove")
 
@@ -663,8 +709,7 @@
 ; 	  (begin
 ; 	    (values ret-object))))))
 
-(import-lambda-definition 
+(import-lambda-definition bdb-create-int 
-    bdb-create-int 
   (env-handle flags) 
   "scsh_bdb_create")
 
@@ -681,8 +726,7 @@
 	    (add-finalizer! handle close-database)
 	    handle)))))
 
-(import-lambda-definition 
+(import-lambda-definition bdb-open-int 
-    bdb-open-int 
   (db-handle db-file database txnid type flags mode)
   "scsh_bdb_open")
 
@@ -699,6 +743,12 @@
 		    (flags->value flags) mode)
       => raise-bdb-condition))))
 
+(define (open-database/fork . args)
+  (wait (fork
+	 (lambda ()
+	   (apply open-database args))))
+  (values))
+
 (define (close-database db-handle . args)
   (let-optionals args
       ((flags (or (current-flags) '())))
@@ -710,8 +760,7 @@
 	 (else
 	  (set-database-closed?! db-handle #t))))))
 
-(import-lambda-definition 
+(import-lambda-definition bdb-put-int 
-    bdb-put-int 
   (db-handle key data txn-id flags)
   "scsh_bdb_put")
 
@@ -723,8 +772,13 @@
      ((bdb-put-int db-handle key data txn-id (flags->value flags))
       => raise-bdb-condition))))
 
-(import-lambda-definition 
+(define (database-put/fork . args)
-    bdb-get-int 
+  (wait (fork
+	 (lambda ()
+	   (apply database-put args))))
+  (values))
+
+(import-lambda-definition bdb-get-int 
   (db-handle key txn-id flags)
   "scsh_bdb_get")
 
@@ -740,8 +794,21 @@
 	      (raise-bdb-condition result))
 	  result))))
 
-(import-lambda-definition 
+(define (database-get/fork . args)
-    bdb-del-int 
+  (receive (rport wport)
+      (pipe)
+    (wait (fork (lambda ()
+		  (cond
+		   ((apply database-get args)
+		    => (lambda (byte-vector)
+			 (write (byte-vector->list byte-vector) wport)))
+		   (else (write #f wport))))))
+    (let ((result (read rport)))
+      (if (list? result)
+	  (list->byte-vector result)
+	  result))))
+
+(import-lambda-definition bdb-del-int 
   (db-handle key txn-id flags)
   "scsh_bdb_del")
 
@@ -753,8 +820,13 @@
      ((bdb-del-int db-handle key txn-id (flags->value flags))
       => raise-bdb-condition))))
 
-(import-lambda-definition 
+(define (database-delete-item/fork . args)
-    bdb-truncate-int 
+  (wait (fork 
+	 (lambda ()
+	   (apply database-delete-item args))))
+  (values))
+
+(import-lambda-definition bdb-truncate-int 
   (db-home txn-id flags)
   "scsh_bdb_truncate")
 
@@ -766,8 +838,13 @@
      ((bdb-truncate-int db-handle txn-id (flags->value flags))
       => raise-bdb-condition))))
 
-(import-lambda-definition 
+(define (database-truncate/fork . args)
-    bdb-sync-int 
+  (wait (fork
+	 (lambda ()
+	   (apply database-truncate args))))
+  (values))
+
+(import-lambda-definition bdb-sync-int 
   (db-handle)
   "scsh_bdb_sync")
 
@@ -782,11 +859,10 @@
 (define (set-database-encrypt! database password . args)
   (let-optionals args
       ((flags (or (current-flags) '())))
-    (let ((result 
+    (cond 
-	   (bdb-set-encrypt database password (flags->value flags))))
+     ((bdb-set-encrypt database password (flags->value flags))
-      (if (integer? result)
+      => raise-bdb-condition))))
-	  (raise-bdb-condition result)
+
-	  (values)))))
 ;; retest
 (import-lambda-definition bdb-get-encrypt-flags
   (database)
@@ -869,8 +945,7 @@
 	 page-size
 	 (raise-bdb-condition error-code)))))
 
-(import-lambda-definition 
+(import-lambda-definition bdb-create-cursor-int 
-    bdb-create-cursor-int 
   (db-handle txn-id flags)
   "scsh_bdb_create_cursor")
 
@@ -888,12 +963,11 @@
 	    (add-finalizer! result cursor-finalizer)
 	    result)))))
 
-(import-lambda-definition 
+(import-lambda-definition bdb-cursor-cget-int 
-    bdb-cursor-cget-int 
   (db-handle flags)
   "scsh_bdb_cursor_cget")
 
-(define (database-get-via-cursor cursor . args)
+(define (cursor-get cursor . args)
   (let-optionals args
       ((flags (or (current-flags) '())))
     (let ((result (bdb-cursor-cget-int cursor (flags->value flags))))
@@ -901,8 +975,59 @@
 	  (raise-bdb-condition result)
 	  result))))
 
-(import-lambda-definition 
+(define (cursor-get/fork . args)
-    bdb-txn-begin-int 
+  (receive (rport wport)
+      (pipe)
+    (wait (fork (lambda ()
+		  (write (byte-vector->list (apply cursor-get args)) 
+			 wport))))
+    (list->byte-vector (read rport))))
+
+(import-lambda-definition bdb-cursor-count
+  (cursor)
+  "scsh_bdb_cursor_count")
+
+(define (cursor-count cursor)
+  (call-with-values
+   (lambda ()
+     (apply values (bdb-cursor-count cursor)))
+   (lambda (error-code count)
+     (if (zero? error-code)
+	 count
+	 (raise-bdb-condition error-code)))))
+
+(import-lambda-definition bdb-cursor-del
+  (cursor)
+  "scsh_bdb_cursor_del")
+
+(define (cursor-delete-item cursor)
+  (cond ((bdb-cursor-del cursor)
+	 => raise-bdb-condition)))
+
+(define (cursor-delete-item/fork cursor)
+  (wait (fork 
+	 (lambda ()
+	   (cursor-delete-item cursor))))
+  (values))
+
+(import-lambda-definition bdb-cursor-put
+  (cursor key data flags)
+  "scsh_bdb_cursor_put")
+
+(define (cursor-put cursor key data . args)
+  (let-optionals args
+      ((flags (or (current-flags) '())))
+    (cond
+     ((bdb-cursor-put cursor key data flags)
+      => raise-bdb-condition))))
+
+(define (cursor-put/fork args)
+  (wait (fork 
+	 (lambda ()
+	   (apply cursor-put args))))
+  (values))
+
+(import-lambda-definition bdb-txn-begin-int 
   (env-handle parent flags)
   "scsh_bdb_txn_begin")
 
@@ -918,9 +1043,9 @@
 	    (database-env-weak-list-add! db-env result)
 	    result)))))
 
-(import-lambda-definition 
+(import-lambda-definition bdb-txn-abort-int 
-    bdb-txn-abort-int (txn-id)
+  (txn-id)
-    "scsh_bdb_txn_abort")
+  "scsh_bdb_txn_abort")
 
 (define (abort-transaction txn-id)
   (let ((result (bdb-txn-abort-int txn-id)))
@@ -928,8 +1053,7 @@
 	(raise-bdb-condition result)
 	(values))))
 
-(import-lambda-definition 
+(import-lambda-definition bdb-txn-commit-int 
-    bdb-txn-commit-int 
   (txn-id flags)
   "scsh_bdb_txn_commit")
 
@@ -974,3 +1098,19 @@
   (let ((port (make-string-input-port
 	       (byte-vector->string byte-vector))))
     (read port)))
+
+(define (byte-vector->list bv)
+  (let ((length (byte-vector-length bv)))
+    (let lp ((index (- length 1)) (res '()))
+      (if (< index 0)
+	  res
+	  (lp (- index 1) (cons (byte-vector-ref bv index) res))))))
+
+(define (list->byte-vector lst)
+  (let ((bv (make-byte-vector (length lst) 0)))
+    (let lp ((index 0) (lst lst))
+      (if (null? lst)
+	  bv
+	  (begin
+	    (byte-vector-set! bv index (car lst))
+	    (lp (+ index 1) (cdr lst)))))))

scheme/packages.scm

@@ -6,6 +6,9 @@
      with-database-flags
      as-transaction
 
+     berkeley-db-version
+     berkeley-db-version-string
+
      flag-object?
      flag-elements
      flag-name
@@ -42,7 +45,9 @@
 
      make-database-env
      remove-database
+     remove-database/fork
      rename-database
+     rename-database/fork
      database-env-open
      set-database-env-data-dir!
      database-env-data-dirs
@@ -70,11 +75,16 @@
      
      make-database
      open-database
+     open-database/fork
      close-database
      database-put
+     database-put/fork
      database-get
+     database-get/fork
      database-delete-item
+     database-delete-item/fork
      database-truncate
+     database-truncate/fork
      database-sync
      set-database-encrypt!
      database-encrypt-flags
@@ -87,7 +97,13 @@
      database-page-size
      
      make-cursor
-     database-get-via-cursor
+     cursor-get
+     cursor-get/fork
+     cursor-count
+     cursor-delete-item
+     cursor-delete-item/fork
+     cursor-put
+     cursor-put/fork
      
      begin-transaction
      abort-transaction
@@ -115,6 +131,6 @@
 	define-record-types
 	finite-types
 	external-calls
-	(subset scsh-level-0 (fork pipe)))
+	(subset scsh-level-0 (fork wait pipe)))
   (files bdb))