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 assocs
   4 biassocs classes.struct combinators destructors gdbm.ffi io.backend
   5 kernel libc literals locals math namespaces sequences serialize
   6 strings ;
   7 IN: gdbm
   8
   9 TUPLE: gdbm
  10     { name       string  }
  11     { block-size integer }
  12     { flags      integer initial: $ GDBM_WRCREAT }
  13     { mode       integer initial: OCT: 644 } ;
  14
  15 SINGLETONS:
  16     gdbm-no-error             gdbm-malloc-error
  17     gdbm-block-size-error     gdbm-file-open-error
  18     gdbm-file-write-error     gdbm-file-seek-error
  19     gdbm-file-read-error      gdbm-bad-magic-number
  20     gdbm-empty-database       gdbm-cant-be-reader
  21     gdbm-cant-be-writer       gdbm-reader-cant-delete
  22     gdbm-reader-cant-store    gdbm-reader-cant-reorganize
  23     gdbm-unknown-update       gdbm-item-not-found
  24     gdbm-reorganize-failed    gdbm-cannot-replace
  25     gdbm-illegal-data         gdbm-option-already-set
  26     gdbm-illegal-option ;
  27
  28 ERROR: gdbm-unknown-error error ;
  29
  30
  31 <PRIVATE
  32
  33 : error-table ( -- table )
  34     {
  35         {  0 gdbm-no-error               }
  36         {  1 gdbm-malloc-error           }
  37         {  2 gdbm-block-size-error       }
  38         {  3 gdbm-file-open-error        }
  39         {  4 gdbm-file-write-error       }
  40         {  5 gdbm-file-seek-error        }
  41         {  6 gdbm-file-read-error        }
  42         {  7 gdbm-bad-magic-number       }
  43         {  8 gdbm-empty-database         }
  44         {  9 gdbm-cant-be-reader         }
  45         { 10 gdbm-cant-be-writer         }
  46         { 11 gdbm-reader-cant-delete     }
  47         { 12 gdbm-reader-cant-store      }
  48         { 13 gdbm-reader-cant-reorganize }
  49         { 14 gdbm-unknown-update         }
  50         { 15 gdbm-item-not-found         }
  51         { 16 gdbm-reorganize-failed      }
  52         { 17 gdbm-cannot-replace         }
  53         { 18 gdbm-illegal-data           }
  54         { 19 gdbm-option-already-set     }
  55         { 20 gdbm-illegal-option         }
  56     } >biassoc ;
  57
  58 : error>code ( error -- code )
  59     dup error-table value-at [ ] [ gdbm-unknown-error ] ?if ;
  60
  61 : code>error ( code -- error ) error-table at ;
  62
  63 : gdbm-throw ( -- * ) gdbm_errno code>error throw ;
  64
  65 : check-error ( ret -- ) 0 = [ gdbm-throw ] unless ;
  66
  67
  68 SYMBOL: current-dbf
  69
  70 : dbf ( -- dbf ) current-dbf get ;
  71
  72 : gdbm-open ( gdbm -- dbf )
  73     {
  74         [ name>> normalize-path ]
  75         [ block-size>> ] [ flags>> ] [ mode>> ]
  76     } cleave f gdbm_open [ gdbm-throw ] unless* ;
  77
  78 DESTRUCTOR: gdbm-close
  79
  80 : object>datum ( obj -- datum )
  81     object>bytes [ malloc-byte-array &free ] [ length ] bi
  82     datum <struct-boa> ;
  83
  84 : datum>object* ( datum -- obj ? )
  85     [ dptr>> ] [ dsize>> ] bi over
  86     [ memory>byte-array bytes>object t ] [ drop f ] if ;
  87
  88 : gdbm-store ( key content flag -- )
  89     [
  90         { [ dbf ] [ object>datum ] [ object>datum ] [ ] } spread
  91         gdbm_store check-error
  92     ] with-destructors ;
  93
  94 PRIVATE>
  95
  96
  97 : gdbm-error-message ( error -- msg ) error>code gdbm_strerror ;
  98
  99 : gdbm-replace ( key content -- ) GDBM_REPLACE gdbm-store ;
 100 : gdbm-insert ( key content -- ) GDBM_INSERT gdbm-store ;
 101
 102 : gdbm-delete ( key -- )
 103     [ dbf swap object>datum gdbm_delete check-error ]
 104     with-destructors ;
 105
 106 : gdbm-fetch* ( key -- content ? )
 107     [ dbf swap object>datum gdbm_fetch datum>object* ]
 108     with-destructors ;
 109
 110 : gdbm-first-key* ( -- key ? )
 111     [ dbf gdbm_firstkey datum>object* ] with-destructors ;
 112
 113 : gdbm-next-key* ( key -- key ? )
 114     [ dbf swap object>datum gdbm_nextkey datum>object* ]
 115     with-destructors ;
 116
 117 : gdbm-fetch ( key -- content/f ) gdbm-fetch* drop ;
 118 : gdbm-first-key ( -- key/f ) gdbm-first-key* drop ;
 119 : gdbm-next-key ( key -- key/f ) gdbm-next-key* drop ;
 120
 121 : gdbm-reorganize ( -- ) dbf gdbm_reorganize check-error ;
 122
 123 : gdbm-sync ( -- ) dbf gdbm_sync ;
 124
 125 : gdbm-exists ( key -- ? )
 126     [ dbf swap object>datum gdbm_exists c-bool> ]
 127     with-destructors ;
 128
 129 <PRIVATE
 130
 131 :: (gdbm-setopt) ( option value -- )
 132     [
 133         int heap-size dup malloc &free :> ( size ptr )
 134         value ptr 0 int set-alien-value
 135         dbf option ptr size gdbm_setopt check-error
 136     ] with-destructors ;
 137
 138 PRIVATE>
 139
 140 : gdbm-setopt ( option value -- )
 141     over GDBM_CACHESIZE = [ >c-bool ] unless (gdbm-setopt) ;
 142
 143 : gdbm-fdesc ( -- desc ) dbf gdbm_fdesc ;
 144
 145 : with-gdbm ( gdbm quot -- )
 146     [ gdbm-open &gdbm-close current-dbf set ] prepose curry
 147     [ with-scope ] curry with-destructors ; inline