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