! 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 ;
: 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
: gdbm-store ( key content flag -- )
[
- { [ dbf ] [ object>datum ] [ object>datum ] [ ] } spread
+ [ dbf ] 3dip
+ [ object>datum ] [ object>datum ] [ ] tri*
gdbm_store check-error
] with-destructors ;
-:: (gdbm-setopt) ( option value -- )
+:: (setopt) ( value option -- )
[
int heap-size dup malloc &free :> ( size ptr )
value ptr 0 int set-alien-value
dbf option ptr size gdbm_setopt check-error
] with-destructors ;
+: setopt ( value option -- )
+ [ GDBM_CACHESIZE = [ >c-bool ] unless ] keep (setopt) ;
+
PRIVATE>
-ALIAS: gdbm-error-message gdbm_strerror
+: gdbm-info ( -- str ) gdbm_version ;
-: gdbm-replace ( key content -- ) GDBM_REPLACE gdbm-store ;
-: gdbm-insert ( key content -- ) GDBM_INSERT gdbm-store ;
+: gdbm-error-message ( error -- msg )
+ enum>number gdbm_strerror ;
-: gdbm-delete ( key -- )
+: replace ( key content -- ) GDBM_REPLACE gdbm-store ;
+: insert ( key content -- ) GDBM_INSERT gdbm-store ;
+
+: 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-setopt ( option value -- )
- over GDBM_CACHESIZE = [ >c-bool ] unless (gdbm-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
+