extra/gdbm/gdbm.factor

   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 classes.struct combinators destructors gdbm.ffi io.backend kernel libc
   5 literals locals math namespaces sequences serialize strings ;
   6 IN: gdbm
   7
   8 TUPLE: gdbm
   9     { name       string  }
  10     { block-size integer }
  11     { flags      integer initial: $ GDBM_WRCREAT }
  12     { mode       integer initial: OCT: 644 } ;
  13
  14
  15 <PRIVATE
  16
  17 : gdbm-throw ( -- * ) gdbm_errno throw ;
  18
  19 : check-error ( ret -- ) 0 = [ gdbm-throw ] unless ;
  20
  21 SYMBOL: current-dbf
  22
  23 : dbf ( -- dbf ) current-dbf get ;
  24
  25 : gdbm-open ( gdbm -- dbf )
  26     {
  27         [ name>> normalize-path ]
  28         [ block-size>> ] [ flags>> ] [ mode>> ]
  29     } cleave f gdbm_open [ gdbm-throw ] unless* ;
  30
  31 DESTRUCTOR: gdbm-close
  32
  33 : object>datum ( obj -- datum )
  34     object>bytes [ malloc-byte-array &free ] [ length ] bi
  35     datum <struct-boa> ;
  36
  37 : datum>object* ( datum -- obj ? )
  38     [ dptr>> ] [ dsize>> ] bi over
  39     [ memory>byte-array bytes>object t ] [ drop f ] if ;
  40
  41 : gdbm-store ( key content flag -- )
  42     [
  43         { [ dbf ] [ object>datum ] [ object>datum ] [ ] } spread
  44         gdbm_store check-error
  45     ] with-destructors ;
  46
  47 :: (setopt) ( value option -- )
  48     [
  49         int heap-size dup malloc &free :> ( size ptr )
  50         value ptr 0 int set-alien-value
  51         dbf option ptr size gdbm_setopt check-error
  52     ] with-destructors ;
  53
  54 : setopt ( value option -- )
  55     [ GDBM_CACHESIZE = [ >c-bool ] unless ] keep (setopt) ;
  56
  57 PRIVATE>
  58
  59
  60 ALIAS: gdbm-error-message gdbm_strerror
  61
  62 : gdbm-replace ( key content -- ) GDBM_REPLACE gdbm-store ;
  63 : gdbm-insert ( key content -- ) GDBM_INSERT gdbm-store ;
  64
  65 : gdbm-delete ( key -- )
  66     [ dbf swap object>datum gdbm_delete check-error ]
  67     with-destructors ;
  68
  69 : gdbm-fetch* ( key -- content ? )
  70     [ dbf swap object>datum gdbm_fetch datum>object* ]
  71     with-destructors ;
  72
  73 : gdbm-first-key* ( -- key ? )
  74     [ dbf gdbm_firstkey datum>object* ] with-destructors ;
  75
  76 : gdbm-next-key* ( key -- key ? )
  77     [ dbf swap object>datum gdbm_nextkey datum>object* ]
  78     with-destructors ;
  79
  80 : gdbm-fetch ( key -- content/f ) gdbm-fetch* drop ;
  81 : gdbm-first-key ( -- key/f ) gdbm-first-key* drop ;
  82 : gdbm-next-key ( key -- key/f ) gdbm-next-key* drop ;
  83
  84 : gdbm-reorganize ( -- ) dbf gdbm_reorganize check-error ;
  85
  86 : gdbm-sync ( -- ) dbf gdbm_sync ;
  87
  88 : gdbm-exists ( key -- ? )
  89     [ dbf swap object>datum gdbm_exists c-bool> ]
  90     with-destructors ;
  91
  92 : gdbm-set-cache-size ( size -- ) GDBM_CACHESIZE setopt ;
  93 : gdbm-set-sync-mode ( ? -- ) GDBM_SYNCMODE setopt ;
  94 : gdbm-set-block-pool ( ? -- ) GDBM_CENTFREE setopt ;
  95 : gdbm-set-block-merging ( ? -- ) GDBM_COALESCEBLKS setopt ;
  96
  97 : gdbm-fdesc ( -- desc ) dbf gdbm_fdesc ;
  98
  99 : with-gdbm ( gdbm quot -- )
 100     [ gdbm-open &gdbm-close current-dbf set ] prepose curry
 101     [ with-scope ] curry with-destructors ; inline