Merge branch 'gdbm' of http://github.com/dmsh/factor
Slava Pestov
commit
3159b66103
|
|
@ -0,0 +1 @@
|
|||
Dmitry Shubin
|
||||
|
|
@ -0,0 +1 @@
|
|||
Dmitry Shubin
|
||||
|
|
@ -0,0 +1,49 @@
|
|||
! Copyright (C) 2010 Dmitry Shubin.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.libraries alien.syntax classes.struct
|
||||
combinators system ;
|
||||
IN: gdbm.ffi
|
||||
|
||||
<< "libgdbm" os {
|
||||
{ [ unix? ] [ "libgdbm.so" ] }
|
||||
{ [ winnt? ] [ "gdbm.dll" ] }
|
||||
{ [ macosx? ] [ "libgdbm.dylib" ] }
|
||||
} cond cdecl add-library >>
|
||||
|
||||
LIBRARY: libgdbm
|
||||
|
||||
C-GLOBAL: c-string gdbm_version
|
||||
|
||||
CONSTANT: GDBM_SYNC HEX: 20
|
||||
CONSTANT: GDBM_NOLOCK HEX: 40
|
||||
|
||||
CONSTANT: GDBM_INSERT 0
|
||||
CONSTANT: GDBM_REPLACE 1
|
||||
|
||||
CONSTANT: GDBM_CACHESIZE 1
|
||||
CONSTANT: GDBM_SYNCMODE 3
|
||||
CONSTANT: GDBM_CENTFREE 4
|
||||
CONSTANT: GDBM_COALESCEBLKS 5
|
||||
|
||||
STRUCT: datum { dptr char* } { dsize int } ;
|
||||
|
||||
C-TYPE: _GDBM_FILE
|
||||
TYPEDEF: _GDBM_FILE* GDBM_FILE
|
||||
|
||||
CALLBACK: void fatal_func_cb ;
|
||||
FUNCTION: GDBM_FILE gdbm_open ( c-string name, int block_size, int read_write, int mode, fatal_func_cb fatal_func ) ;
|
||||
FUNCTION-ALIAS: gdbm-close void gdbm_close ( GDBM_FILE dbf ) ;
|
||||
FUNCTION: int gdbm_store ( GDBM_FILE dbf, datum key, datum content, int flag ) ;
|
||||
FUNCTION: datum gdbm_fetch ( GDBM_FILE dbf, datum key ) ;
|
||||
FUNCTION: int gdbm_delete ( GDBM_FILE dbf, datum key ) ;
|
||||
FUNCTION: datum gdbm_firstkey ( GDBM_FILE dbf ) ;
|
||||
FUNCTION: datum gdbm_nextkey ( GDBM_FILE dbf, datum key ) ;
|
||||
FUNCTION: int gdbm_reorganize ( GDBM_FILE dbf ) ;
|
||||
FUNCTION: void gdbm_sync ( GDBM_FILE dbf ) ;
|
||||
FUNCTION: int gdbm_exists ( GDBM_FILE dbf, datum key ) ;
|
||||
FUNCTION: int gdbm_setopt ( GDBM_FILE dbf, int option, int* value, int size ) ;
|
||||
FUNCTION: int gdbm_fdesc ( GDBM_FILE dbf ) ;
|
||||
|
||||
C-GLOBAL: int gdbm_errno
|
||||
|
||||
FUNCTION: c-string gdbm_strerror ( int errno ) ;
|
||||
|
|
@ -0,0 +1,147 @@
|
|||
! Copyright (C) 2010 Dmitry Shubin.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: gdbm.ffi gdbm.private help.markup help.syntax kernel math
|
||||
quotations strings ;
|
||||
IN: gdbm
|
||||
|
||||
HELP: gdbm
|
||||
{ $class-description "Instance of this class is used as database configuration object. It has following slots:"
|
||||
|
||||
{ $table
|
||||
{ { $slot "name" } "The file name of the database." }
|
||||
{ { $slot "block-size" } "The size of a single transfer from disk to memory. If the value is less than 512, the file system blocksize is used (this is default)." }
|
||||
{ { $slot "role" } "Determines what kind of access the user wants to obtain (see below)." }
|
||||
{ { $slot "sync" } { "Being set to " { $link t } " causes all database operations to be synchronized to the disk." } }
|
||||
{ { $slot "nolock" } { "Being set to " { $link t } " prevents gdbm from performing any locking on the database file." } }
|
||||
{ { $slot "mode" } "An integer representing standard UNIX access permissions." }
|
||||
}
|
||||
"The " { $slot "role" } " can be set to one of the folowing values:"
|
||||
{ $table
|
||||
{ { $snippet "reader" } "The user can only read from existing database." }
|
||||
{ { $snippet "writer" } "The user can access existing database as reader and writer." }
|
||||
{ { $snippet "wrcreat" } "Open the database for reading and writing if it exists and create new one otherwise." }
|
||||
{ { $snippet "newdb" } "Create empty database even if there is already one with the same name." }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: <gdbm>
|
||||
{ $values { "gdbm" gdbm } }
|
||||
{ $description "Creates database configuration object with all slots set to their default values. See " { $link gdbm } " for complete slots description." } ;
|
||||
|
||||
HELP: gdbm-info
|
||||
{ $values { "str" string } }
|
||||
{ $description "Returns version number and build date." } ;
|
||||
|
||||
HELP: delete
|
||||
{ $values { "key" object } }
|
||||
{ $description "Removes the keyed item from the database." } ;
|
||||
|
||||
HELP: gdbm-error-message
|
||||
{ $values { "error" gdbm-error } { "msg" string } }
|
||||
{ $description "Returns error message in human readable format." } ;
|
||||
|
||||
HELP: exists?
|
||||
{ $values { "key" object } { "?" boolean } }
|
||||
{ $description "Searches for a particular key without retreiving it." } ;
|
||||
|
||||
HELP: each-key
|
||||
{ $values { "quot" quotation } }
|
||||
{ $description "Applies the quotation to the each key in the database." } ;
|
||||
|
||||
HELP: each-value
|
||||
{ $values { "quot" quotation } }
|
||||
{ $description "Applies the quotation to the each value in the database." } ;
|
||||
|
||||
HELP: each-record
|
||||
{ $values { "quot" quotation } }
|
||||
{ $description "Applies the quotation to the each key-value pair in the database." } ;
|
||||
|
||||
HELP: gdbm-file-descriptor
|
||||
{ $values { "desc" integer } }
|
||||
{ $description "Returns the file descriptor of the database. This is used for manual database locking if it was opened with " { $snippet "nolock" } " flag set to " { $link t } "." } ;
|
||||
|
||||
HELP: fetch
|
||||
{ $values
|
||||
{ "key" object }
|
||||
{ "content/f" { "the value associated with " { $snippet "key" } " or " { $link f } " if there is no such key" } }
|
||||
}
|
||||
{ $description "Looks up a given key and returns value associated with it. This word makes no distinction between a missing value and a value set to " { $link f } "." } ;
|
||||
|
||||
HELP: fetch*
|
||||
{ $values { "key" object } { "content" object } { "?" boolean } }
|
||||
{ $description "Looks up a given key and returns value associated with it. The boolean flag can decide between the case of a missing value, and a value of " { $link f } "." } ;
|
||||
|
||||
HELP: first-key
|
||||
{ $values { "key/f" object } }
|
||||
{ $description "Returns first key in the database. This word makes no distinction between an empty database case and a case of a first value set to " { $link f } "." } ;
|
||||
|
||||
HELP: first-key*
|
||||
{ $values { "key" object } { "?" boolean } }
|
||||
{ $description "Returns first key in the database. The boolean flag can decide between the case of an empty database and a case of a first value set to " { $link f } "." } ;
|
||||
|
||||
HELP: insert
|
||||
{ $values { "key" object } { "content" object } }
|
||||
{ $description "Inserts record into the database. Throws an error if the key already exists." } ;
|
||||
|
||||
HELP: next-key
|
||||
{ $values { "key" object } { "key/f" object } }
|
||||
{ $description "Given a key returns next key in the database. This word makes no distinction between reaching the end of the database case and a case of a next value set to " { $link f } "." } ;
|
||||
|
||||
HELP: next-key*
|
||||
{ $values { "key" object } { "next-key" object } { "?" boolean } }
|
||||
{ $description "Given a key returns next key in the database. The boolean flag can decide between the case of reaching the end of the database and a case of a next value set to " { $link f } "." } ;
|
||||
|
||||
HELP: reorganize
|
||||
{ $description "Reorganisation is a process of shinking the space used by gdbm. This requires creating a new file and moving all elements from old gdbm file to new one." } ;
|
||||
|
||||
HELP: replace
|
||||
{ $values { "key" object } { "content" object } }
|
||||
{ $description "Inserts record into the database replacing old value with the new one if the key already exists." } ;
|
||||
|
||||
HELP: set-block-merging
|
||||
{ $values { "?" boolean } }
|
||||
{ $description "If set, this option causes adjacent free blocks to be merged. The default is " { $link f } "." } ;
|
||||
|
||||
HELP: set-block-pool
|
||||
{ $values { "?" boolean } }
|
||||
{ $description "If set, this option causes all subsequent free blocks to be placed in the global pool. The default is " { $link f } "." } ;
|
||||
|
||||
HELP: set-cache-size
|
||||
{ $values { "size" integer } }
|
||||
{ $description "Sets the size of the internal bucket cache. The default value is 100. This option may only be set once." } ;
|
||||
|
||||
HELP: set-sync-mode
|
||||
{ $values { "?" boolean } }
|
||||
{ $description "Turns on or off file system synchronization. The default is " { $link f } "." } ;
|
||||
|
||||
HELP: synchronize
|
||||
{ $description "Performs database synchronization: make sure the disk version of the database has been completely updated." } ;
|
||||
|
||||
HELP: with-gdbm
|
||||
{ $values
|
||||
{ "gdbm" "a database configuration object" } { "quot" quotation }
|
||||
}
|
||||
{ $description "Calls the quotation with a database bound to " { $link current-dbf } " symbol." } ;
|
||||
|
||||
|
||||
ARTICLE: "gdbm" "GNU Database Manager"
|
||||
"The " { $vocab-link "gdbm" } " vocabulary provides an interface to GNU DataBase Manager. This is a GNU implementation of the standard Unix dbm library, originally developed at Berkeley."
|
||||
|
||||
$nl
|
||||
"This is a very brief manual. For a more detailed description consult the official gdbm documentation."
|
||||
|
||||
{ $heading "Basics" }
|
||||
"All interaction with gdbm database should be realized using special combinator which automates all work for database initialisation and cleanup. All initialisation options are passed to combinator with a database configuration object."
|
||||
{ $subsections gdbm <gdbm> with-gdbm }
|
||||
"For actual record manipulation the following words are used:"
|
||||
{ $subsections insert exists? fetch delete }
|
||||
|
||||
{ $heading "Sequential access" }
|
||||
"It is possible to iterate through all records in the database with"
|
||||
{ $subsections first-key next-key }
|
||||
"The following combinators, however, provide more convenient way to do that:"
|
||||
{ $subsections each-key each-value each-record }
|
||||
"The order in which records are accessed has nothing to do with the order in which records have been stored. Note that these words can only be used in read-only algorithms since delete operation re-arranges the hash table."
|
||||
;
|
||||
|
||||
ABOUT: "gdbm"
|
||||
|
|
@ -0,0 +1,63 @@
|
|||
! Copyright (C) 2010 Dmitry Shubin.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays continuations gdbm io.directories
|
||||
io.files.temp kernel sequences sets tools.test ;
|
||||
IN: gdbm.tests
|
||||
|
||||
: db-path ( -- filename ) "test.db" temp-file ;
|
||||
|
||||
: CLEANUP ( -- ) [ db-path delete-file ] ignore-errors ;
|
||||
|
||||
: test.db ( -- gdbm ) <gdbm> db-path >>name ;
|
||||
|
||||
: with-test.db ( quot -- ) test.db swap with-gdbm ; inline
|
||||
|
||||
|
||||
CLEANUP
|
||||
|
||||
|
||||
[
|
||||
test.db reader >>role [ ] with-gdbm
|
||||
] [ gdbm-file-open-error = ] must-fail-with
|
||||
|
||||
[ f ] [ [ "foo" exists? ] with-test.db ] unit-test
|
||||
|
||||
[ ] [ [ "foo" 41 insert ] with-test.db ] unit-test
|
||||
|
||||
[
|
||||
db-path [ "foo" 42 insert ] with-gdbm-writer
|
||||
] [ gdbm-cannot-replace = ] must-fail-with
|
||||
|
||||
[ ]
|
||||
[
|
||||
[
|
||||
"foo" 42 replace
|
||||
"bar" 43 replace
|
||||
"baz" 44 replace
|
||||
] with-test.db
|
||||
] unit-test
|
||||
|
||||
[ 42 t ] [ db-path [ "foo" fetch* ] with-gdbm-reader ] unit-test
|
||||
|
||||
[ f f ] [ [ "unknown" fetch* ] with-test.db ] unit-test
|
||||
|
||||
[
|
||||
[
|
||||
300 set-cache-size 300 set-cache-size
|
||||
] with-test.db
|
||||
] [ gdbm-option-already-set = ] must-fail-with
|
||||
|
||||
[ t ]
|
||||
[
|
||||
V{ } [ [ 2array append ] each-record ] with-test.db
|
||||
V{ "foo" "bar" "baz" 42 43 44 } set=
|
||||
|
||||
] unit-test
|
||||
|
||||
[ f ]
|
||||
[
|
||||
test.db newdb >>role [ "foo" exists? ] with-gdbm
|
||||
] unit-test
|
||||
|
||||
|
||||
CLEANUP
|
||||
|
|
@ -0,0 +1,160 @@
|
|||
! Copyright (C) 2010 Dmitry Shubin.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types alien.data alien.destructors
|
||||
alien.enums alien.syntax classes.struct combinators destructors
|
||||
gdbm.ffi io.backend kernel libc locals math namespaces sequences
|
||||
serialize strings ;
|
||||
IN: gdbm
|
||||
|
||||
ENUM: gdbm-role reader writer wrcreat newdb ;
|
||||
|
||||
TUPLE: gdbm
|
||||
{ name string }
|
||||
{ block-size integer }
|
||||
{ role initial: wrcreat }
|
||||
{ sync boolean }
|
||||
{ nolock boolean }
|
||||
{ mode integer initial: OCT: 644 } ;
|
||||
|
||||
: <gdbm> ( -- gdbm ) gdbm new ;
|
||||
|
||||
ENUM: gdbm-error
|
||||
gdbm-no-error
|
||||
gdbm-malloc-error
|
||||
gdbm-block-size-error
|
||||
gdbm-file-open-error
|
||||
gdbm-file-write-error
|
||||
gdbm-file-seek-error
|
||||
gdbm-file-read-error
|
||||
gdbm-bad-magic-number
|
||||
gdbm-empty-database
|
||||
gdbm-cant-be-reader
|
||||
gdbm-cant-be-writer
|
||||
gdbm-reader-cant-delete
|
||||
gdbm-reader-cant-store
|
||||
gdbm-reader-cant-reorganize
|
||||
gdbm-unknown-update
|
||||
gdbm-item-not-found
|
||||
gdbm-reorganize-failed
|
||||
gdbm-cannot-replace
|
||||
gdbm-illegal-data
|
||||
gdbm-option-already-set
|
||||
gdbm-illegal-option ;
|
||||
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: gdbm-throw ( -- * ) gdbm_errno gdbm-error number>enum throw ;
|
||||
|
||||
: check-error ( ret -- ) 0 = [ gdbm-throw ] unless ;
|
||||
|
||||
SYMBOL: current-dbf
|
||||
|
||||
: dbf ( -- dbf ) current-dbf get ;
|
||||
|
||||
: get-flag ( gdbm -- n )
|
||||
[ role>> enum>number ]
|
||||
[ sync>> GDBM_SYNC 0 ? ]
|
||||
[ nolock>> GDBM_NOLOCK 0 ? ]
|
||||
tri bitor bitor ;
|
||||
|
||||
: gdbm-open ( gdbm -- dbf )
|
||||
{
|
||||
[ name>> normalize-path ]
|
||||
[ block-size>> ] [ get-flag ] [ mode>> ]
|
||||
} cleave f gdbm_open [ gdbm-throw ] unless* ;
|
||||
|
||||
DESTRUCTOR: gdbm-close
|
||||
|
||||
: object>datum ( obj -- datum )
|
||||
object>bytes [ malloc-byte-array &free ] [ length ] bi
|
||||
datum <struct-boa> ;
|
||||
|
||||
: datum>object* ( datum -- obj ? )
|
||||
[ dptr>> ] [ dsize>> ] bi over
|
||||
[ memory>byte-array bytes>object t ] [ drop f ] if ;
|
||||
|
||||
: gdbm-store ( key content flag -- )
|
||||
[
|
||||
{ [ dbf ] [ object>datum ] [ object>datum ] [ ] } spread
|
||||
gdbm_store check-error
|
||||
] with-destructors ;
|
||||
|
||||
:: (setopt) ( value option -- )
|
||||
[
|
||||
int heap-size dup malloc &free :> ( size ptr )
|
||||
value ptr 0 int set-alien-value
|
||||
dbf option ptr size gdbm_setopt check-error
|
||||
] with-destructors ;
|
||||
|
||||
: setopt ( value option -- )
|
||||
[ GDBM_CACHESIZE = [ >c-bool ] unless ] keep (setopt) ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
||||
: gdbm-info ( -- str ) gdbm_version ;
|
||||
|
||||
: gdbm-error-message ( error -- msg )
|
||||
enum>number gdbm_strerror ;
|
||||
|
||||
: replace ( key content -- ) GDBM_REPLACE gdbm-store ;
|
||||
: insert ( key content -- ) GDBM_INSERT gdbm-store ;
|
||||
|
||||
: delete ( key -- )
|
||||
[ dbf swap object>datum gdbm_delete check-error ]
|
||||
with-destructors ;
|
||||
|
||||
: fetch* ( key -- content ? )
|
||||
[ dbf swap object>datum gdbm_fetch datum>object* ]
|
||||
with-destructors ;
|
||||
|
||||
: first-key* ( -- key ? )
|
||||
[ dbf gdbm_firstkey datum>object* ] with-destructors ;
|
||||
|
||||
: next-key* ( key -- next-key ? )
|
||||
[ dbf swap object>datum gdbm_nextkey datum>object* ]
|
||||
with-destructors ;
|
||||
|
||||
: fetch ( key -- content/f ) fetch* drop ;
|
||||
: first-key ( -- key/f ) first-key* drop ;
|
||||
: next-key ( key -- key/f ) next-key* drop ;
|
||||
|
||||
:: each-key ( ... quot: ( ... key -- ... ) -- ... )
|
||||
first-key*
|
||||
[ [ next-key* ] [ quot keep ] do while ] when drop ; inline
|
||||
|
||||
: each-value ( ... quot: ( ... value -- ... ) -- ... )
|
||||
[ fetch ] prepose each-key ; inline
|
||||
|
||||
: each-record ( ... quot: ( ... key value -- ... ) -- ... )
|
||||
[ dup fetch ] prepose each-key ; inline
|
||||
|
||||
: reorganize ( -- ) dbf gdbm_reorganize check-error ;
|
||||
|
||||
: synchronize ( -- ) dbf gdbm_sync ;
|
||||
|
||||
: exists? ( key -- ? )
|
||||
[ dbf swap object>datum gdbm_exists c-bool> ]
|
||||
with-destructors ;
|
||||
|
||||
: set-cache-size ( size -- ) GDBM_CACHESIZE setopt ;
|
||||
: set-sync-mode ( ? -- ) GDBM_SYNCMODE setopt ;
|
||||
: set-block-pool ( ? -- ) GDBM_CENTFREE setopt ;
|
||||
: set-block-merging ( ? -- ) GDBM_COALESCEBLKS setopt ;
|
||||
|
||||
: gdbm-file-descriptor ( -- desc ) dbf gdbm_fdesc ;
|
||||
|
||||
: with-gdbm ( gdbm quot -- )
|
||||
[ gdbm-open &gdbm-close current-dbf set ] prepose curry
|
||||
[ with-scope ] curry with-destructors ; inline
|
||||
|
||||
:: with-gdbm-role ( name role quot -- )
|
||||
<gdbm> name >>name role >>role quot with-gdbm ; inline
|
||||
|
||||
: with-gdbm-reader ( name quot -- )
|
||||
reader swap with-gdbm-role ; inline
|
||||
|
||||
: with-gdbm-writer ( name quot -- )
|
||||
writer swap with-gdbm-role ; inline
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
GNU DataBase Manager
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
bindings
|
||||
database
|
||||
Loading…
Reference in New Issue