diff --git a/extra/gdbm/authors.txt b/extra/gdbm/authors.txt new file mode 100644 index 0000000000..e1702c7130 --- /dev/null +++ b/extra/gdbm/authors.txt @@ -0,0 +1 @@ +Dmitry Shubin diff --git a/extra/gdbm/ffi/authors.txt b/extra/gdbm/ffi/authors.txt new file mode 100644 index 0000000000..e1702c7130 --- /dev/null +++ b/extra/gdbm/ffi/authors.txt @@ -0,0 +1 @@ +Dmitry Shubin diff --git a/extra/gdbm/ffi/ffi.factor b/extra/gdbm/ffi/ffi.factor new file mode 100644 index 0000000000..f2c866769e --- /dev/null +++ b/extra/gdbm/ffi/ffi.factor @@ -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 ) ; diff --git a/extra/gdbm/gdbm-docs.factor b/extra/gdbm/gdbm-docs.factor new file mode 100644 index 0000000000..18e5d5cf33 --- /dev/null +++ b/extra/gdbm/gdbm-docs.factor @@ -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: +{ $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 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" diff --git a/extra/gdbm/gdbm-tests.factor b/extra/gdbm/gdbm-tests.factor new file mode 100644 index 0000000000..4a102deeb1 --- /dev/null +++ b/extra/gdbm/gdbm-tests.factor @@ -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 ) 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 diff --git a/extra/gdbm/gdbm.factor b/extra/gdbm/gdbm.factor new file mode 100644 index 0000000000..2fe758f539 --- /dev/null +++ b/extra/gdbm/gdbm.factor @@ -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 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 ; + + +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 ; + +: 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 -- ) + 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 + diff --git a/extra/gdbm/summary.txt b/extra/gdbm/summary.txt new file mode 100644 index 0000000000..85056ecaef --- /dev/null +++ b/extra/gdbm/summary.txt @@ -0,0 +1 @@ +GNU DataBase Manager diff --git a/extra/gdbm/tags.txt b/extra/gdbm/tags.txt new file mode 100644 index 0000000000..2e60f4bec8 --- /dev/null +++ b/extra/gdbm/tags.txt @@ -0,0 +1,2 @@ +bindings +database