gdbm: add higher level interface

diff --git a/extra/gdbm/authors.txt b/extra/gdbm/authors.txt
new file mode 100644 (file)
index 0000000..e1702c7
--- /dev/null
+++ b/extra/gdbm/authors.txt
@@ -0,0 +1 @@
+Dmitry Shubin

diff --git a/extra/gdbm/ffi/ffi.factor b/extra/gdbm/ffi/ffi.factor
index cf63b566fbfeeb08a569542f0ae0b024b26f99e8..9776cdd0def32d89753383d515595e23dd969463 100644 (file)
--- a/extra/gdbm/ffi/ffi.factor
+++ b/extra/gdbm/ffi/ffi.factor
@@ -38,7 +38,7 @@ TYPEDEF: _GDBM_FILE* GDBM_FILE
 
 CALLBACK: void fatal_func_cb ;
 FUNCTION: GDBM_FILE gdbm_open ( c-string name, int block_size, int read_write, int mode, fatal_func_cb fatal_func ) ;
-FUNCTION: void gdbm_close ( GDBM_FILE dbf ) ;
+FUNCTION-ALIAS: gdbm-close void gdbm_close ( GDBM_FILE dbf ) ;
 FUNCTION: int gdbm_store ( GDBM_FILE dbf, datum key, datum content, int flag ) ;
 FUNCTION: datum gdbm_fetch ( GDBM_FILE dbf, datum key ) ;
 FUNCTION: int gdbm_delete ( GDBM_FILE dbf, datum key ) ;
@@ -74,3 +74,5 @@ CONSTANT: GDBM_OPT_ILLEGAL            20
 
 TYPEDEF: int gdbm_error
 C-GLOBAL: gdbm_error gdbm_errno
+
+FUNCTION: c-string gdbm_strerror ( gdbm_error errno ) ;

diff --git a/extra/gdbm/gdbm.factor b/extra/gdbm/gdbm.factor
new file mode 100644 (file)
index 0000000..55da935
--- /dev/null
+++ b/extra/gdbm/gdbm.factor
@@ -0,0 +1,85 @@
+! Copyright (C) 2010 Dmitry Shubin.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.data alien.destructors
+classes.struct combinators destructors gdbm.ffi io.backend kernel libc
+literals math namespaces sequences serialize strings ;
+IN: gdbm
+
+: object>datum ( obj -- datum )
+    object>bytes [ malloc-byte-array &free ] [ length ] bi
+    datum <struct-boa> ;
+
+: datum>object* ( datum -- obj ? )
+    [ dptr>> ] [ dsize>> ] bi over
+    [ memory>byte-array bytes>object t ] [ drop f ] if ;
+
+SYMBOL: current-dbf
+
+: dbf ( -- dbf ) current-dbf get ;
+
+TUPLE: gdbm
+    { name       string  }
+    { block-size integer }
+    { flags      integer initial: $ GDBM_WRCREAT }
+    { mode       integer initial: OCT: 644 } ;
+
+DESTRUCTOR: gdbm-close
+
+ERROR: gdbm-error errno msg ;
+
+: gdbm-throw ( -- * ) gdbm_errno dup gdbm_strerror gdbm-error ;
+
+: check-error ( ret -- ) 0 = [ gdbm-throw ] unless ;
+
+: gdbm-open ( gdbm -- dbf )
+    {
+        [ name>> normalize-path ]
+        [ block-size>> ] [ flags>> ] [ mode>> ]
+    } cleave f gdbm_open [ gdbm-throw ] unless* ;
+
+: gdbm-store ( key content flag -- )
+    [
+        { [ dbf ] [ object>datum ] [ object>datum ] [ ] } spread
+        gdbm_store check-error
+    ] with-destructors ;
+
+: gdbm-replace ( key content -- ) GDBM_REPLACE gdbm-store ;
+
+: gdbm-insert ( key content -- ) GDBM_INSERT gdbm-store ;
+
+: gdbm-fetch* ( key -- content ? )
+    [ dbf swap object>datum gdbm_fetch datum>object* ]
+    with-destructors ;
+
+: gdbm-fetch ( key -- content/f ) gdbm-fetch* drop ;
+
+: gdbm-delete ( key -- )
+    [ dbf swap object>datum gdbm_delete check-error ]
+    with-destructors ;
+
+: gdbm-firstkey* ( -- key ? )
+    [ dbf gdbm_firstkey datum>object* ] with-destructors ;
+
+: gdbm-firstkey ( -- key/f ) gdbm-firstkey* drop ;
+
+: gdbm-nextkey* ( key -- key ? )
+    [ dbf swap object>datum gdbm_nextkey datum>object* ]
+    with-destructors ;
+
+: gdbm-nextkey ( key -- key/f ) gdbm-nextkey* drop ;
+
+: gdbm-reorganize ( -- ) dbf gdbm_reorganize check-error ;
+
+: gdbm-sync ( -- ) dbf gdbm_sync ;
+
+: gdbm-exists ( key -- ? )
+    [ dbf swap object>datum gdbm_exists c-bool> ]
+    with-destructors ;
+
+! : gdbm-setopt ( option value size -- ret ) ;
+
+: gdbm-fdesc ( -- desc ) dbf gdbm_fdesc ;
+
+: with-gdbm ( gdbm quot -- )
+    [ gdbm-open &gdbm-close current-dbf set ] prepose curry
+    [ with-scope ] curry with-destructors ; inline