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 alien.syntax classes.struct combinators continuations
   5 destructors fry gdbm.ffi io.backend kernel libc locals math namespaces
   6 sequences serialize strings ;
   7 IN: gdbm
   8
   9 ENUM: gdbm-role reader writer wrcreat newdb ;
  10
  11 TUPLE: gdbm
  12     { name string }
  13     { block-size integer }
  14     { role initial: wrcreat }
  15     { sync boolean }
  16     { nolock boolean }
  17     { mode integer initial: 0o644 } ;
  18
  19 : <gdbm> ( -- gdbm ) gdbm new ;
  20
  21 ENUM: gdbm-error
  22     gdbm-no-error
  23     gdbm-malloc-error
  24     gdbm-block-size-error
  25     gdbm-file-open-error
  26     gdbm-file-write-error
  27     gdbm-file-seek-error
  28     gdbm-file-read-error
  29     gdbm-bad-magic-number
  30     gdbm-empty-database
  31     gdbm-cant-be-reader
  32     gdbm-cant-be-writer
  33     gdbm-reader-cant-delete
  34     gdbm-reader-cant-store
  35     gdbm-reader-cant-reorganize
  36     gdbm-unknown-update
  37     gdbm-item-not-found
  38     gdbm-reorganize-failed
  39     gdbm-cannot-replace
  40     gdbm-illegal-data
  41     gdbm-option-already-set
  42     gdbm-illegal-option ;
  43
  44 <PRIVATE
  45
  46 : gdbm-errno ( -- n )
  47     [ gdbm_errno ] [ drop gdbm_errno_location int deref ] recover ;
  48
  49 : gdbm-throw ( -- * ) gdbm-errno gdbm-error number>enum throw ;
  50
  51 : check-error ( ret -- ) 0 = [ gdbm-throw ] unless ;
  52
  53 SYMBOL: current-dbf
  54
  55 : dbf ( -- dbf ) current-dbf get ;
  56
  57 : get-flag ( gdbm -- n )
  58     [ role>>   enum>number ]
  59     [ sync>>   GDBM_SYNC 0 ? ]
  60     [ nolock>> GDBM_NOLOCK 0 ? ]
  61     tri bitor bitor ;
  62
  63 : gdbm-open ( gdbm -- dbf )
  64     {
  65         [ name>> normalize-path ]
  66         [ block-size>> ] [ get-flag ] [ mode>> ]
  67     } cleave f gdbm_open [ gdbm-throw ] unless* ;
  68
  69 DESTRUCTOR: gdbm-close
  70
  71 : object>datum ( obj -- datum )
  72     object>bytes [ malloc-byte-array &free ] [ length ] bi
  73     datum boa ;
  74
  75 : datum>object* ( datum -- obj ? )
  76     [ dptr>> ] [ dsize>> ] bi over
  77     [ memory>byte-array bytes>object t ] [ drop f ] if ;
  78
  79 : gdbm-store ( key content flag -- )
  80     [
  81         [ dbf ] 3dip
  82         [ object>datum ] [ object>datum ] [ ] tri*
  83         gdbm_store check-error
  84     ] with-destructors ;
  85
  86 :: (gdbm-setopt) ( value option -- )
  87     [
  88         int heap-size dup malloc &free :> ( size ptr )
  89         value ptr 0 int set-alien-value
  90         dbf option ptr size gdbm_setopt check-error
  91     ] with-destructors ;
  92
  93 : gdbm-setopt ( value option -- )
  94     [ GDBM_CACHESIZE = [ >c-bool ] unless ] keep (gdbm-setopt) ;
  95
  96 PRIVATE>
  97
  98
  99 : gdbm-info ( -- str ) gdbm_version ;
 100
 101 : gdbm-error-message ( error -- msg )
 102     enum>number gdbm_strerror ;
 103
 104 : gdbm-replace ( key content -- ) GDBM_REPLACE gdbm-store ;
 105
 106 : gdbm-insert ( key content -- ) GDBM_INSERT gdbm-store ;
 107
 108 : gdbm-delete ( key -- )
 109     [ dbf swap object>datum gdbm_delete check-error ]
 110     with-destructors ;
 111
 112 : gdbm-fetch* ( key -- content ? )
 113     [ dbf swap object>datum gdbm_fetch datum>object* ]
 114     with-destructors ;
 115
 116 : gdbm-first-key* ( -- key ? )
 117     [ dbf gdbm_firstkey datum>object* ] with-destructors ;
 118
 119 : gdbm-next-key* ( key -- next-key ? )
 120     [ dbf swap object>datum gdbm_nextkey datum>object* ]
 121     with-destructors ;
 122
 123 : gdbm-fetch ( key -- content/f ) gdbm-fetch* drop ;
 124 : gdbm-first-key ( -- key/f ) gdbm-first-key* drop ;
 125 : gdbm-next-key ( key -- key/f ) gdbm-next-key* drop ;
 126
 127 :: each-gdbm-key ( ... quot: ( ... key -- ... ) -- ... )
 128     gdbm-first-key*
 129     [ [ gdbm-next-key* ] [ quot keep ] do while ] when drop ; inline
 130
 131 : each-gdbm-value ( ... quot: ( ... value -- ... ) -- ... )
 132     [ gdbm-fetch ] prepose each-gdbm-key ; inline
 133
 134 : each-gdbm-record ( ... quot: ( ... key value -- ... ) -- ... )
 135     [ dup gdbm-fetch ] prepose each-gdbm-key ; inline
 136
 137 : gdbm-reorganize ( -- ) dbf gdbm_reorganize check-error ;
 138
 139 : gdbm-synchronize ( -- ) dbf gdbm_sync ;
 140
 141 : gdbm-exists? ( key -- ? )
 142     [ dbf swap object>datum gdbm_exists c-bool> ]
 143     with-destructors ;
 144
 145 : set-gdbm-cache-size ( size -- ) GDBM_CACHESIZE gdbm-setopt ;
 146 : set-gdbm-sync-mode ( ? -- ) GDBM_SYNCMODE gdbm-setopt ;
 147 : set-gdbm-block-pool ( ? -- ) GDBM_CENTFREE gdbm-setopt ;
 148 : set-gdbm-block-merging ( ? -- ) GDBM_COALESCEBLKS gdbm-setopt ;
 149
 150 : gdbm-file-descriptor ( -- desc ) dbf gdbm_fdesc ;
 151
 152 : with-gdbm ( gdbm quot -- )
 153     '[
 154         _ gdbm-open &gdbm-close current-dbf
 155         _ with-variable
 156     ] with-destructors ; inline
 157
 158 :: with-gdbm-role ( name role quot -- )
 159     <gdbm> name >>name role >>role quot with-gdbm ; inline
 160
 161 : with-gdbm-reader ( name quot -- )
 162     reader swap with-gdbm-role ; inline
 163
 164 : with-gdbm-writer ( name quot -- )
 165     writer swap with-gdbm-role ; inline