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 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 ERROR: gdbm-error errno msg ;
  15
  16
  17 <PRIVATE
  18
  19 : gdbm-throw ( -- * ) gdbm_errno dup gdbm_strerror gdbm-error ;
  20
  21 : check-error ( ret -- ) 0 = [ gdbm-throw ] unless ;
  22
  23 SYMBOL: current-dbf
  24
  25 : dbf ( -- dbf ) current-dbf get ;
  26
  27 : gdbm-open ( gdbm -- dbf )
  28     {
  29         [ name>> normalize-path ]
  30         [ block-size>> ] [ flags>> ] [ mode>> ]
  31     } cleave f gdbm_open [ gdbm-throw ] unless* ;
  32
  33 DESTRUCTOR: gdbm-close
  34
  35 : object>datum ( obj -- datum )
  36     object>bytes [ malloc-byte-array &free ] [ length ] bi
  37     datum <struct-boa> ;
  38
  39 : datum>object* ( datum -- obj ? )
  40     [ dptr>> ] [ dsize>> ] bi over
  41     [ memory>byte-array bytes>object t ] [ drop f ] if ;
  42
  43 : gdbm-store ( key content flag -- )
  44     [
  45         { [ dbf ] [ object>datum ] [ object>datum ] [ ] } spread
  46         gdbm_store check-error
  47     ] with-destructors ;
  48
  49 PRIVATE>
  50
  51
  52 : gdbm-replace ( key content -- ) GDBM_REPLACE gdbm-store ;
  53 : gdbm-insert ( key content -- ) GDBM_INSERT gdbm-store ;
  54
  55 : gdbm-delete ( key -- )
  56     [ dbf swap object>datum gdbm_delete check-error ]
  57     with-destructors ;
  58
  59 : gdbm-fetch* ( key -- content ? )
  60     [ dbf swap object>datum gdbm_fetch datum>object* ]
  61     with-destructors ;
  62
  63 : gdbm-first-key* ( -- key ? )
  64     [ dbf gdbm_firstkey datum>object* ] with-destructors ;
  65
  66 : gdbm-next-key* ( key -- key ? )
  67     [ dbf swap object>datum gdbm_nextkey datum>object* ]
  68     with-destructors ;
  69
  70 : gdbm-fetch ( key -- content/f ) gdbm-fetch* drop ;
  71 : gdbm-first-key ( -- key/f ) gdbm-first-key* drop ;
  72 : gdbm-next-key ( key -- key/f ) gdbm-next-key* drop ;
  73
  74 : gdbm-reorganize ( -- ) dbf gdbm_reorganize check-error ;
  75
  76 : gdbm-sync ( -- ) dbf gdbm_sync ;
  77
  78 : gdbm-exists ( key -- ? )
  79     [ dbf swap object>datum gdbm_exists c-bool> ]
  80     with-destructors ;
  81
  82 ! : gdbm-setopt ( option value size -- ret ) ;
  83
  84 : gdbm-fdesc ( -- desc ) dbf gdbm_fdesc ;
  85
  86 : with-gdbm ( gdbm quot -- )
  87     [ gdbm-open &gdbm-close current-dbf set ] prepose curry
  88     [ with-scope ] curry with-destructors ; inline