use radix literals

[factor.git] / extra / gdbm / gdbm.factor

diff --git a/extra/gdbm/gdbm.factor b/extra/gdbm/gdbm.factor
index 6145211e4b310df741fabcb51bd480bdba43527a..a69809f4e3dc97aaa4eaeb9df05f3db153273a13 100644 (file)
--- a/extra/gdbm/gdbm.factor
+++ b/extra/gdbm/gdbm.factor
@@ -1,20 +1,50 @@
 ! 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 locals math namespaces sequences serialize strings ;
+alien.enums alien.syntax classes.struct combinators destructors
+gdbm.ffi io.backend kernel libc locals math namespaces sequences
+serialize strings ;
 IN: gdbm
 
+ENUM: gdbm-role reader writer wrcreat newdb ;
+
 TUPLE: gdbm
-    { name       string  }
+    { name string }
     { block-size integer }
-    { flags      integer initial: $ GDBM_WRCREAT }
-    { mode       integer initial: OCT: 644 } ;
+    { role initial: wrcreat }
+    { sync boolean }
+    { nolock boolean }
+    { mode integer initial: 0o644 } ;
+
+: <gdbm> ( -- gdbm ) gdbm new ;
+
+ENUM: gdbm-error
+    gdbm-no-error
+    gdbm-malloc-error
+    gdbm-block-size-error
+    gdbm-file-open-error
+    gdbm-file-write-error
+    gdbm-file-seek-error
+    gdbm-file-read-error
+    gdbm-bad-magic-number
+    gdbm-empty-database
+    gdbm-cant-be-reader
+    gdbm-cant-be-writer
+    gdbm-reader-cant-delete
+    gdbm-reader-cant-store
+    gdbm-reader-cant-reorganize
+    gdbm-unknown-update
+    gdbm-item-not-found
+    gdbm-reorganize-failed
+    gdbm-cannot-replace
+    gdbm-illegal-data
+    gdbm-option-already-set
+    gdbm-illegal-option ;
 
 
 <PRIVATE
 
-: gdbm-throw ( -- * ) gdbm_errno throw ;
+: gdbm-throw ( -- * ) gdbm_errno gdbm-error number>enum throw ;
 
 : check-error ( ret -- ) 0 = [ gdbm-throw ] unless ;
 
@@ -22,10 +52,16 @@ SYMBOL: current-dbf
 
 : dbf ( -- dbf ) current-dbf get ;
 
+: get-flag ( gdbm -- n )
+    [ role>>   enum>number ]
+    [ sync>>   GDBM_SYNC 0 ? ]
+    [ nolock>> GDBM_NOLOCK 0 ? ]
+    tri bitor bitor ;
+
 : gdbm-open ( gdbm -- dbf )
     {
         [ name>> normalize-path ]
-        [ block-size>> ] [ flags>> ] [ mode>> ]
+        [ block-size>> ] [ get-flag ] [ mode>> ]
     } cleave f gdbm_open [ gdbm-throw ] unless* ;
 
 DESTRUCTOR: gdbm-close
@@ -40,7 +76,8 @@ DESTRUCTOR: gdbm-close
 
 : gdbm-store ( key content flag -- )
     [
-        { [ dbf ] [ object>datum ] [ object>datum ] [ ] } spread
+        [ dbf ] 3dip
+        [ object>datum ] [ object>datum ] [ ] tri*
         gdbm_store check-error
     ] with-destructors ;
 
@@ -57,45 +94,68 @@ DESTRUCTOR: gdbm-close
 PRIVATE>
 
 
-ALIAS: gdbm-error-message gdbm_strerror
+: gdbm-info ( -- str ) gdbm_version ;
+
+: gdbm-error-message ( error -- msg )
+    enum>number gdbm_strerror ;
 
-: gdbm-replace ( key content -- ) GDBM_REPLACE gdbm-store ;
-: gdbm-insert ( key content -- ) GDBM_INSERT gdbm-store ;
+: replace ( key content -- ) GDBM_REPLACE gdbm-store ;
+: insert ( key content -- ) GDBM_INSERT gdbm-store ;
 
-: gdbm-delete ( key -- )
+: delete ( key -- )
     [ dbf swap object>datum gdbm_delete check-error ]
     with-destructors ;
 
-: gdbm-fetch* ( key -- content ? )
+: fetch* ( key -- content ? )
     [ dbf swap object>datum gdbm_fetch datum>object* ]
     with-destructors ;
 
-: gdbm-first-key* ( -- key ? )
+: first-key* ( -- key ? )
     [ dbf gdbm_firstkey datum>object* ] with-destructors ;
 
-: gdbm-next-key* ( key -- key ? )
+: next-key* ( key -- next-key ? )
     [ dbf swap object>datum gdbm_nextkey datum>object* ]
     with-destructors ;
 
-: gdbm-fetch ( key -- content/f ) gdbm-fetch* drop ;
-: gdbm-first-key ( -- key/f ) gdbm-first-key* drop ;
-: gdbm-next-key ( key -- key/f ) gdbm-next-key* drop ;
+: fetch ( key -- content/f ) fetch* drop ;
+: first-key ( -- key/f ) first-key* drop ;
+: next-key ( key -- key/f ) next-key* drop ;
+
+:: each-key ( ... quot: ( ... key -- ... ) -- ... )
+    first-key*
+    [ [ next-key* ] [ quot keep ] do while ] when drop ; inline
+
+: each-value ( ... quot: ( ... value -- ... ) -- ... )
+    [ fetch ] prepose each-key ; inline
 
-: gdbm-reorganize ( -- ) dbf gdbm_reorganize check-error ;
+: each-record ( ... quot: ( ... key value -- ... ) -- ... )
+    [ dup fetch ] prepose each-key ; inline
 
-: gdbm-sync ( -- ) dbf gdbm_sync ;
+: reorganize ( -- ) dbf gdbm_reorganize check-error ;
 
-: gdbm-exists ( key -- ? )
+: synchronize ( -- ) dbf gdbm_sync ;
+
+: exists? ( key -- ? )
     [ dbf swap object>datum gdbm_exists c-bool> ]
     with-destructors ;
 
-: gdbm-set-cache-size ( size -- ) GDBM_CACHESIZE setopt ;
-: gdbm-set-sync-mode ( ? -- ) GDBM_SYNCMODE setopt ;
-: gdbm-set-block-pool ( ? -- ) GDBM_CENTFREE setopt ;
-: gdbm-set-block-merging ( ? -- ) GDBM_COALESCEBLKS setopt ;
+: set-cache-size ( size -- ) GDBM_CACHESIZE setopt ;
+: set-sync-mode ( ? -- ) GDBM_SYNCMODE setopt ;
+: set-block-pool ( ? -- ) GDBM_CENTFREE setopt ;
+: set-block-merging ( ? -- ) GDBM_COALESCEBLKS setopt ;
 
-: gdbm-fdesc ( -- desc ) dbf gdbm_fdesc ;
+: gdbm-file-descriptor ( -- desc ) dbf gdbm_fdesc ;
 
 : with-gdbm ( gdbm quot -- )
     [ gdbm-open &gdbm-close current-dbf set ] prepose curry
     [ with-scope ] curry with-destructors ; inline
+
+:: with-gdbm-role ( name role quot -- )
+    <gdbm> name >>name role >>role quot with-gdbm ; inline
+
+: with-gdbm-reader ( name quot -- )
+    reader swap with-gdbm-role ; inline
+
+: with-gdbm-writer ( name quot -- )
+    writer swap with-gdbm-role ; inline
+