1 ! Copyright (C) 2010 Dmitry Shubin.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien.c-types alien.data alien.destructors
4 alien.enums classes.struct combinators destructors gdbm.ffi io.backend
5 kernel libc locals math namespaces sequences serialize strings ;
10 { block-size integer }
11 { role initial: wrcreat }
14 { mode integer initial: OCT: 644 } ;
16 : <gdbm> ( -- gdbm ) gdbm new ;
21 : gdbm-throw ( -- * ) gdbm_errno throw ;
23 : check-error ( ret -- ) 0 = [ gdbm-throw ] unless ;
27 : dbf ( -- dbf ) current-dbf get ;
29 : get-flag ( gdbm -- n )
30 [ role>> enum>number ]
31 [ sync>> GDBM_SYNC 0 ? ]
32 [ nolock>> GDBM_NOLOCK 0 ? ]
35 : gdbm-open ( gdbm -- dbf )
37 [ name>> normalize-path ]
38 [ block-size>> ] [ get-flag ] [ mode>> ]
39 } cleave f gdbm_open [ gdbm-throw ] unless* ;
41 DESTRUCTOR: gdbm-close
43 : object>datum ( obj -- datum )
44 object>bytes [ malloc-byte-array &free ] [ length ] bi
47 : datum>object* ( datum -- obj ? )
48 [ dptr>> ] [ dsize>> ] bi over
49 [ memory>byte-array bytes>object t ] [ drop f ] if ;
51 : gdbm-store ( key content flag -- )
53 { [ dbf ] [ object>datum ] [ object>datum ] [ ] } spread
54 gdbm_store check-error
57 :: (setopt) ( value option -- )
59 int heap-size dup malloc &free :> ( size ptr )
60 value ptr 0 int set-alien-value
61 dbf option ptr size gdbm_setopt check-error
64 : setopt ( value option -- )
65 [ GDBM_CACHESIZE = [ >c-bool ] unless ] keep (setopt) ;
70 ALIAS: gdbm-error-message gdbm_strerror
72 : gdbm-replace ( key content -- ) GDBM_REPLACE gdbm-store ;
73 : gdbm-insert ( key content -- ) GDBM_INSERT gdbm-store ;
75 : gdbm-delete ( key -- )
76 [ dbf swap object>datum gdbm_delete check-error ]
79 : gdbm-fetch* ( key -- content ? )
80 [ dbf swap object>datum gdbm_fetch datum>object* ]
83 : gdbm-first-key* ( -- key ? )
84 [ dbf gdbm_firstkey datum>object* ] with-destructors ;
86 : gdbm-next-key* ( key -- next-key ? )
87 [ dbf swap object>datum gdbm_nextkey datum>object* ]
90 : gdbm-fetch ( key -- content/f ) gdbm-fetch* drop ;
91 : gdbm-first-key ( -- key/f ) gdbm-first-key* drop ;
92 : gdbm-next-key ( key -- key/f ) gdbm-next-key* drop ;
94 : gdbm-reorganize ( -- ) dbf gdbm_reorganize check-error ;
96 : gdbm-sync ( -- ) dbf gdbm_sync ;
98 : gdbm-exists ( key -- ? )
99 [ dbf swap object>datum gdbm_exists c-bool> ]
102 : gdbm-set-cache-size ( size -- ) GDBM_CACHESIZE setopt ;
103 : gdbm-set-sync-mode ( ? -- ) GDBM_SYNCMODE setopt ;
104 : gdbm-set-block-pool ( ? -- ) GDBM_CENTFREE setopt ;
105 : gdbm-set-block-merging ( ? -- ) GDBM_COALESCEBLKS setopt ;
107 : gdbm-fdesc ( -- desc ) dbf gdbm_fdesc ;
109 : with-gdbm ( gdbm quot -- )
110 [ gdbm-open &gdbm-close current-dbf set ] prepose curry
111 [ with-scope ] curry with-destructors ; inline