scsh-conservatory
/
scsh-bdb
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Compare commits

base: scsh-conservatory:main
Branches Tags
scsh-conservatory:main
scsh-conservatory:import-1.1.1
..
compare: scsh-conservatory:import-1.1.1
Branches Tags
scsh-conservatory:main
scsh-conservatory:import-1.1.1

1 Commits
main ... import-1.1

Author SHA1 Message Date
eknauel 295e119a58 Imported Daniel Brintzinger's code 
Added package definition, fixed some bugs and rewrote some weird code parts
 2004-09-17 10:50:50 +00:00
15 changed files with 640 additions and 2727 deletions
Show Stats Expand all files Collapse all files

2
AUTHORS
View File

@ -1,2 +0,0 @@
Daniel Brintzinger
Eric Knauel

26
COPYING
View File

@ -1,26 +0,0 @@
Copyright (c) 2004 by Eric Knauel
Copyright (c) 2004 by Daniel Brintzinger
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. The name of the authors may not be used to endorse or promote products
derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

0
ChangeLog
View File

229
INSTALL
View File

@ -1,229 +0,0 @@
Copyright (C) 1994, 1995, 1996, 1999, 2000, 2001, 2002 Free Software
Foundation, Inc.
This file is free documentation; the Free Software Foundation gives
unlimited permission to copy, distribute and modify it.
Basic Installation
==================
These are generic installation instructions.
The `configure' shell script attempts to guess correct values for
various system-dependent variables used during compilation. It uses
those values to create a `Makefile' in each directory of the package.
It may also create one or more `.h' files containing system-dependent
definitions. Finally, it creates a shell script `config.status' that
you can run in the future to recreate the current configuration, and a
file `config.log' containing compiler output (useful mainly for
debugging `configure').
It can also use an optional file (typically called `config.cache'
and enabled with `--cache-file=config.cache' or simply `-C') that saves
the results of its tests to speed up reconfiguring. (Caching is
disabled by default to prevent problems with accidental use of stale
cache files.)
If you need to do unusual things to compile the package, please try
to figure out how `configure' could check whether to do them, and mail
diffs or instructions to the address given in the `README' so they can
be considered for the next release. If you are using the cache, and at
some point `config.cache' contains results you don't want to keep, you
may remove or edit it.
The file `configure.ac' (or `configure.in') is used to create
`configure' by a program called `autoconf'. You only need
`configure.ac' if you want to change it or regenerate `configure' using
a newer version of `autoconf'.
The simplest way to compile this package is:
1. `cd' to the directory containing the package's source code and type
`./configure' to configure the package for your system. If you're
using `csh' on an old version of System V, you might need to type
`sh ./configure' instead to prevent `csh' from trying to execute
`configure' itself.
Running `configure' takes awhile. While running, it prints some
messages telling which features it is checking for.
2. Type `make' to compile the package.
3. Optionally, type `make check' to run any self-tests that come with
the package.
4. Type `make install' to install the programs and any data files and
documentation.
5. You can remove the program binaries and object files from the
source code directory by typing `make clean'. To also remove the
files that `configure' created (so you can compile the package for
a different kind of computer), type `make distclean'. There is
also a `make maintainer-clean' target, but that is intended mainly
for the package's developers. If you use it, you may have to get
all sorts of other programs in order to regenerate files that came
with the distribution.
Compilers and Options
=====================
Some systems require unusual options for compilation or linking that
the `configure' script does not know about. Run `./configure --help'
for details on some of the pertinent environment variables.
You can give `configure' initial values for configuration parameters
by setting variables in the command line or in the environment. Here
is an example:
./configure CC=c89 CFLAGS=-O2 LIBS=-lposix
*Note Defining Variables::, for more details.
Compiling For Multiple Architectures
====================================
You can compile the package for more than one kind of computer at the
same time, by placing the object files for each architecture in their
own directory. To do this, you must use a version of `make' that
supports the `VPATH' variable, such as GNU `make'. `cd' to the
directory where you want the object files and executables to go and run
the `configure' script. `configure' automatically checks for the
source code in the directory that `configure' is in and in `..'.
If you have to use a `make' that does not support the `VPATH'
variable, you have to compile the package for one architecture at a
time in the source code directory. After you have installed the
package for one architecture, use `make distclean' before reconfiguring
for another architecture.
Installation Names
==================
By default, `make install' will install the package's files in
`/usr/local/bin', `/usr/local/man', etc. You can specify an
installation prefix other than `/usr/local' by giving `configure' the
option `--prefix=PATH'.
You can specify separate installation prefixes for
architecture-specific files and architecture-independent files. If you
give `configure' the option `--exec-prefix=PATH', the package will use
PATH as the prefix for installing programs and libraries.
Documentation and other data files will still use the regular prefix.
In addition, if you use an unusual directory layout you can give
options like `--bindir=PATH' to specify different values for particular
kinds of files. Run `configure --help' for a list of the directories
you can set and what kinds of files go in them.
If the package supports it, you can cause programs to be installed
with an extra prefix or suffix on their names by giving `configure' the
option `--program-prefix=PREFIX' or `--program-suffix=SUFFIX'.
Optional Features
=================
Some packages pay attention to `--enable-FEATURE' options to
`configure', where FEATURE indicates an optional part of the package.
They may also pay attention to `--with-PACKAGE' options, where PACKAGE
is something like `gnu-as' or `x' (for the X Window System). The
`README' should mention any `--enable-' and `--with-' options that the
package recognizes.
For packages that use the X Window System, `configure' can usually
find the X include and library files automatically, but if it doesn't,
you can use the `configure' options `--x-includes=DIR' and
`--x-libraries=DIR' to specify their locations.
Specifying the System Type
==========================
There may be some features `configure' cannot figure out
automatically, but needs to determine by the type of machine the package
will run on. Usually, assuming the package is built to be run on the
_same_ architectures, `configure' can figure that out, but if it prints
a message saying it cannot guess the machine type, give it the
`--build=TYPE' option. TYPE can either be a short name for the system
type, such as `sun4', or a canonical name which has the form:
CPU-COMPANY-SYSTEM
where SYSTEM can have one of these forms:
OS KERNEL-OS
See the file `config.sub' for the possible values of each field. If
`config.sub' isn't included in this package, then this package doesn't
need to know the machine type.
If you are _building_ compiler tools for cross-compiling, you should
use the `--target=TYPE' option to select the type of system they will
produce code for.
If you want to _use_ a cross compiler, that generates code for a
platform different from the build platform, you should specify the
"host" platform (i.e., that on which the generated programs will
eventually be run) with `--host=TYPE'.
Sharing Defaults
================
If you want to set default values for `configure' scripts to share,
you can create a site shell script called `config.site' that gives
default values for variables like `CC', `cache_file', and `prefix'.
`configure' looks for `PREFIX/share/config.site' if it exists, then
`PREFIX/etc/config.site' if it exists. Or, you can set the
`CONFIG_SITE' environment variable to the location of the site script.
A warning: not all `configure' scripts look for a site script.
Defining Variables
==================
Variables not defined in a site shell script can be set in the
environment passed to `configure'. However, some packages may run
configure again during the build, and the customized values of these
variables may be lost. In order to avoid this problem, you should set
them in the `configure' command line, using `VAR=value'. For example:
./configure CC=/usr/local2/bin/gcc
will cause the specified gcc to be used as the C compiler (unless it is
overridden in the site shell script).
`configure' Invocation
======================
`configure' recognizes the following options to control how it
operates.
`--help'
`-h'
Print a summary of the options to `configure', and exit.
`--version'
`-V'
Print the version of Autoconf used to generate the `configure'
script, and exit.
`--cache-file=FILE'
Enable the cache: use and save the results of the tests in FILE,
traditionally `config.cache'. FILE defaults to `/dev/null' to
disable caching.
`--config-cache'
`-C'
Alias for `--cache-file=config.cache'.
`--quiet'
`--silent'
`-q'
Do not print messages saying which checks are being made. To
suppress all normal output, redirect it to `/dev/null' (any error
messages will still be shown).
`--srcdir=DIR'
Look for the package's source code in directory DIR. Usually
`configure' can determine that directory automatically.
`configure' also accepts some other, not widely useful, options. Run
`configure --help' for more details.

1
Makefile.am
View File

@ -1 +0,0 @@
SUBDIRS = c

0
NEWS
View File

0
README
View File

8
c/Makefile.am
View File

@ -1,8 +0,0 @@
INCLUDES = -I@top_srcdir@/c
libsys_LTLIBRARIES= libscshbdb.la
libscshbdb_la_SOURCES=bdb.c
libscshbdb_la_LDFLAGS=-avoid-version -module
libscshbdb_la_DEPENDENCIES=

1227
c/bdb.c
View File

File diff suppressed because it is too large Load Diff

19
c/bdb.h
View File

@ -9,7 +9,6 @@
/* record types */
static s48_value bdb_db_record_type = S48_FALSE;
static s48_value bdb_env_record_type = S48_FALSE;
static s48_value bdb_lock_record_type = S48_FALSE;
static s48_value bdb_mpoolfile_record_type = S48_FALSE;
static s48_value bdb_txn_record_type = S48_FALSE;
static s48_value bdb_dbc_record_type = S48_FALSE;
@ -31,20 +30,11 @@ s48_value scsh_enter_dbenv(DB_ENV *h);
#define scsh_extract_dbenv(x) \
((DB_ENV *) s48_extract_integer(S48_RECORD_REF(x, 0)))
s48_value scsh_enter_lock(DB_LOCK *l);
#define scsh_extract_lock(x) \
((DB_LOCK *) s48_extract_integer(S48_RECORD_REF(x, 0)))
s48_value scsh_enter_DBT_as_bytevector(DBT* dt);
void scsh_extract_bytevector_as_DBT(s48_value bytevector, DBT* dt);
#define CHECK_BDB_RESULT_CODE(res) \
do { \
if (res != 0) \
fprintf(stderr, "scsh-bdb: %s\n", db_strerror(res)); \
if (res > 0) \
if (res < 0) \
s48_raise_os_error(res); \
if (res < 0) \
if (res > 0) \
return s48_enter_integer(res); \
} while (0);
@ -56,8 +46,3 @@ void scsh_extract_bytevector_as_DBT(s48_value bytevector, DBT* dt);
#define EXTRACT_OPTIONAL_ENV(env) \
((env == S48_FALSE) ? NULL : scsh_extract_dbenv(env))
#define ENTER_INTEGER_CONSTANT(scm_value, c_value) \
S48_GC_PROTECT_GLOBAL(scm_value); \
scm_value = s48_enter_integer(c_value); \
s48_define_exported_binding(#scm_value, scm_value);

39
configure.in
View File

@ -1,39 +0,0 @@
AC_INIT(c/bdb.c)
AM_INIT_AUTOMAKE(scsh-bdb, 0.1)
AM_CONFIG_HEADER(c/config.h)
AC_ENABLE_SHARED
AM_PROG_LIBTOOL
AC_PROG_CC
AC_STDC_HEADERS
dnl scsh include path
AC_ARG_WITH(scsh-includes,
AC_HELP_STRING([--with-scsh-includes=DIR],
[scsh include files are in DIR [default is /usr/local/include]]),
scsh_includes=$withval,
scsh_includes=/usr/local/include)
AC_SUBST(CFLAGS, "$CFLAGS -I${scsh_includes}")
AC_SUBST(CPPFLAGS, "$CPPFLAGS -I${scsh_includes}")
dnl Berkeley DB prefix
AC_ARG_WITH(bdb-prefix,
AC_HELP_STRING([--with-bdb-prefix=DIR],
[Berkeley DB library and include have prefix DIR [default is /usr/local]]),
[bdb_lib=$withval/lib bdb_include=$withval/include],
[bdb_lib=/usr/local/lib bdb_include=/usr/local/include])
AC_SUBST(LDFLAGS, "$LDFLAGS -L${bdb_lib} -ldb-4")
AC_SUBST(CFLAGS, "$CFLAGS -I${bdb_include}")
AC_SUBST(CPPFLAGS, "$CPPFLAGS -I${bdb_include}")
schemedir='${prefix}'"/scheme"
libdir='${prefix}'"/lib"
libsysdir='${prefix}'
AC_SUBST(libdir)
AC_SUBST(libsysdir)
AC_SUBST(schemedir)
AC_SUBST(CC)
AC_OUTPUT([Makefile c/Makefile])

74
pkg-def.scm
View File

@ -1,74 +0,0 @@
(define-package "bdb" (0 1 0)
((install-lib-version (1 0))
(options (bdb-prefix "Uses Berkeley DB library with prefix" "<dir>" #t #f #f)))
(define (display-bold text)
(display "\033[1m")
(display text)
(display "\033[m"))
(newline)
(display-bold "Configuring, compiling and installing C-stubs")
(newline)
(let* ((scsh-includes (include-dir))
(build-host (get-option-value 'build))
(prefix (string-append (get-directory 'lib #f) "/" build-host))
(configure (append
(list "./configure"
(string-append "--prefix=" prefix)
(string-append "--with-scsh-includes=" scsh-includes)
(string-append "--enable-static=no")
(string-append "--build=" build-host))
(cond ((get-option-value 'bdb-prefix)
=> (lambda (prefix)
(list
(string-append "--with-bdb-prefix=" prefix))))
(else '()))))
(make `(make install
,(string-append "DESTDIR=" (get-option-value 'dest-dir)))))
(if (get-option-value 'dry-run)
(begin
(display configure) (newline)
(display make) (newline))
(if (not (and (zero? (run ,configure))
(zero? (run ,make))))
(exit))))
(newline)
(display-bold "Creating load.scm")
(newline)
(let ((schemedir (get-directory 'scheme #f))
(libdir (get-directory 'lib #f)))
(write-to-load-script
`((user)
(load-package 'dynamic-externals)
(open 'dynamic-externals)
(open 'external-calls)
(open 'configure)
(open 'signals)
,@(map (lambda (x) `(run ',x)) tmpl-libtool-la-reader)
(run '(let* ((lib-dir (string-append ,libdir "/" (host)))
(la-file-name (string-append lib-dir "/libscshbdb.la"))
(initializer-name "scsh_init_bdb_bindings"))
(let ((la-alist (read-libtool-la la-file-name)))
(cond
((assoc 'dlname la-alist)
=> (lambda (p)
(let ((module-file (string-append lib-dir "/" (cdr p))))
(dynamic-load module-file)
(call-external (get-external initializer-name)))))
(else
(error "Could not figure out libscshbdb's name" la-file-name))))))
(config)
(load ,(string-append schemedir "/packages.scm"))
(user))))
(newline)
(display-bold "Installing Scheme files")
(newline)
(install-directory-contents "scheme" 'scheme)
)

1215
scheme/bdb.scm
View File

File diff suppressed because it is too large Load Diff

137
scheme/packages.scm
View File

@ -1,29 +1,10 @@
(define-interface berkeley-db-interface
(export
with-database-env
with-database
with-database-flags
as-transaction
berkeley-db-version
berkeley-db-version-string
flag-object?
flag-elements
flag-name
(flag :syntax)
lock-mode-object?
lock-mode-elements
lock-mode-name
(lock-mode :syntax)
return-code-object?
return-code-elements
return-code-name
(return-code :syntax)
bdb-flags-object?
bdb-flags-elements
bdb-flags-name
(bdb-flags :syntax)
database-type-object?
database-type-elements
database-type-name
@ -37,92 +18,35 @@
&bdb-secondary-index-bad bdb-secondary-index-bad?
&bdb-invalid-flag bdb-invalid-flag?
database?
database-env?
mpoolfile?
transaction?
cursor?
bdb-db?
bdb-env?
bdb-mpoolfile?
bdb-txn?
bdb-dbc?
make-database-env
remove-database
remove-database/fork
rename-database
rename-database/fork
database-env-open
set-database-env-data-dir!
database-env-data-dirs
set-database-env-encrypt!
database-env-encrypt-flags
set-database-env-verbose!
database-env-verbose
set-database-env-lock-timeout!
set-database-env-transaction-timeout!
database-env-lock-timeout
database-env-transaction-timeout
set-database-env-tmp-dir!
database-env-tmp-dir
set-database-env-max-transactions!
database-env-max-transactions
set-database-env-transaction-timeout!
database-env-transaction-timeout
set-database-env-flags!
clear-database-env-flags!
database-env-flags
database-env-close
database-env-fresh-locker-id
database-env-free-locker-id
database-env-get-lock
database-env-put-lock
set-database-env-transaction-checkpoint!
make-database
open-database
open-database/fork
close-database
database-put
database-put/fork
database-get
database-get/fork
database-delete-item
database-delete-item/fork
database-truncate
database-truncate/fork
database-sync
set-database-encrypt!
database-encrypt-flags
set-database-flags!
database-flags
turn-database-debugging-on
turn-database-debugging-off
set-database-byte-order!
database-big-endian?
database-little-endian?
set-database-page-size!
database-page-size
make-cursor
cursor-get
cursor-get/fork
cursor-count
cursor-delete-item
cursor-delete-item/fork
cursor-put
cursor-put/fork
begin-transaction
abort-transaction
commit-transaction
string->byte-vector
byte-vector->string
value->byte-vector
byte-vector->value))
bdb-env-create
bdb-env-open
bdb-env-close
;bdb-env-remove
bdb-create
bdb-open
bdb-close
bdb-put
bdb-get
bdb-del
bdb-truncate
bdb-sync
;bdb-create-cursor
;bdb-cursor-cget
bdb-begin-transaction
bdb-abort-transaction
bdb-commit-transaction))
(define-structure berkeley-db berkeley-db-interface
(open scheme
srfi-1
srfi-8
srfi-34
srfi-35
fluids
@ -134,7 +58,6 @@
bitwise
define-record-types
finite-types
external-calls
(subset scsh-level-0 (fork wait pipe)))
external-calls)
(files bdb))

390
test/tests.scm
View File

@ -1,390 +0,0 @@
#!/bin/sh
exec scsh -lel exceptions/load.scm -lel bdb/load.scm -o berkeley-db -e main -s "$0" "$@"
!#
(define *tests* '())
(define (test-dir)
"/tmp/bdb-test/")
(define (add-test! name proc)
(set! *tests* (append *tests* (list (cons name proc)))))
(define (make-empty-test-dir)
(if (file-exists? (test-dir))
(run (rm -rf ,(test-dir))))
(run (mkdir -p ,(test-dir))))
(define (fail-if-error try-thunk else-thunk)
(and (call-with-current-continuation
(lambda (escape)
(with-errno-handler*
(lambda (errno packet)
(escape #f))
try-thunk)))
(else-thunk)))
(add-test!
"berkeley-db-version and berkeley-db-version-string"
(lambda ()
(let ((version (berkeley-db-version)))
(and (list? version)
(= 3 (length version))
(string? (berkeley-db-version-string))))))
(add-test!
"make-database-env"
(lambda ()
(and (database-env? (make-database-env))
(database-env? (make-database-env (flag rpc-client)))
(database-env? (make-database-env (list (flag rpc-client)))))))
;remove-database
;remove-database*
;rename-database
;rename-database*
'(add-test!
"database-env-open"
(lambda ()
(let ((env (make-database-env)))
(fail-if-error
(lambda ()
(database-env-open env (test-dir)
(list (flag truncate) (flag create))))
(lambda () #t)))))
(add-test!
"set/get database-env data-dirs"
(lambda ()
(let ((env (make-database-env))
(dirs #f))
(fail-if-error
(lambda ()
(set-database-env-data-dir! env (test-dir))
(set! dirs (database-env-data-dirs env)))
(lambda () (equal? dirs (list (test-dir))))))))
(add-test!
"set-database-env-encrypt!"
(lambda ()
(let ((env (make-database-env)))
(fail-if-error
(lambda ()
(set-database-env-encrypt! env "foo"))
(lambda () #t)))))
(add-test!
"database-env-encrypt-flags"
(lambda ()
(fail-if-error
(lambda ()
(database-env-encrypt-flags (make-database-env)))
(lambda () #t))))
(add-test!
"set-database-env-lock-timeout! and database-env-lock-timeout"
(lambda ()
(let ((env (make-database-env))
(timeout #f))
(fail-if-error
(lambda ()
(set-database-env-lock-timeout! env 128)
(set! timeout (database-env-lock-timeout env)))
(lambda ()
(equal? timeout 128))))))
(add-test!
"set-database-env-transaction-timeout! and database-env-transaction-timeout"
(lambda ()
(let ((env (make-database-env))
(timeout #f))
(fail-if-error
(lambda ()
(set-database-env-transaction-timeout! env 100)
(set! timeout
(database-env-transaction-timeout env)))
(lambda ()
(equal? timeout 100))))))
(add-test!
"set-database-env-tmp-dir! and database-env-tmp-dir"
(lambda ()
(let ((env (make-database-env))
(dir #f))
(fail-if-error
(lambda ()
(set-database-env-tmp-dir! env (test-dir))
(set! dir (database-env-tmp-dir env)))
(lambda ()
(equal? dir (test-dir)))))))
(add-test!
"set-database-env-max-transactions! and database-env-max-transactions"
(lambda ()
(let ((env (make-database-env))
(max #f))
(fail-if-error
(lambda ()
(set-database-env-max-transactions! env 12)
(set! max (database-env-max-transactions env)))
(lambda ()
(equal? max 12))))))
(add-test!
"set-database-env-flags!, clear-database-env-flags! and database-env-flags"
(lambda ()
(let ((env (make-database-env))
(f1 #f)
(f2 #f)
(f3 #f))
(fail-if-error
(lambda ()
(set! f1 (database-env-flags env))
(set-database-env-flags! env (flag encrypt))
(set! f2 (database-env-flags env))
(clear-database-env-flags! env (flag encrypt))
(set! f3 (database-env-flags env)))
(lambda ()
(and (= f1 f3) (not (= f1 f2))))))))
(add-test!
"database-env-close"
(lambda ()
(fail-if-error
(lambda ()
(database-env-close (make-database-env)))
(lambda () #t))))
(add-test!
"database-env-fresh-locker-id"
(lambda ()
(let ((env (make-database-env))
(id #f))
(fail-if-error
(lambda ()
(database-env-open env (test-dir)
(list (flag init-lock) (flag create)))
(set! id
(database-env-fresh-locker-id env)))
(lambda ()
(integer? id))))))
(add-test!
"database-env-free-locker-id"
(lambda ()
(let ((env (make-database-env)))
(fail-if-error
(lambda ()
(database-env-open env (test-dir)
(list (flag init-lock) (flag create)))
(database-env-free-locker-id
env
(database-env-fresh-locker-id env))
(database-env-close env))
(lambda () #t)))))
;database-env-get-lock
;database-env-put-lock
(add-test!
"set-database-env-transaction-checkpoint!"
(lambda ()
(let ((env (make-database-env)))
(fail-if-error
(lambda ()
(database-env-open env (test-dir)
(list (flag init-transactions) (flag create)))
(set-database-env-transaction-checkpoint! env 100 5)
(database-env-close env))
(lambda () #t)))))
(add-test!
"make-database"
(lambda ()
(let ((db1 #f)
(db2 #f))
(fail-if-error
(lambda ()
(set! db1 (make-database))
(set! db2 (make-database (make-database-env))))
(lambda ()
(and (database? db1) (database? db2)))))))
(add-test!
"open-database"
(lambda ()
(fail-if-error
(lambda ()
(open-database (make-database)
(string-append (test-dir) "/bla.db")
(database-type binary-tree)
(list (flag create) (flag truncate))))
(lambda () #t))))
;open-database/fork
(add-test!
"close-database"
(lambda ()
(fail-if-error
(lambda ()
(let ((db (make-database)))
(open-database db (string-append (test-dir) "/bla.db")
(database-type binary-tree)
(list (flag create) (flag truncate)))
(close-database db)))
(lambda () #t))))
(add-test!
"value->byte-vector and byte-vector->value"
(lambda ()
(let ((conv (lambda (v)
(byte-vector->value
(value->byte-vector v)))))
(fold-right
(lambda (val res)
(and res (equal? val (conv val))))
#t
'(42 42.0 (1 2 3) (1.0 2.0 3.0) ()
"" "abc" #t #f abc
#(vector 1 2 3) #())))))
(add-test!
"string->byte-vector and byte-vector->string"
(lambda ()
(let ((conv (lambda (s)
(byte-vector->string
(string->byte-vector s)))))
(and (string=? "" (conv ""))
(string=? "abc" (conv "abc"))))))
(add-test!
"database-put and database-get"
(lambda ()
(let ((data #f)
(key "donaudampfschifffahrtskapitaenanwaerter")
(value "donaudampfschifffahrtskapitaenspatent"))
(fail-if-error
(lambda ()
(let ((db (make-database)))
(open-database db (string-append (test-dir) "/bla.db")
(database-type binary-tree)
(list (flag create) (flag truncate)))
(database-put db (string->byte-vector key)
(string->byte-vector value))
(set! data (database-get db (string->byte-vector key)))
(close-database db)))
(lambda ()
(equal? (byte-vector->string data) value))))))
(add-test!
"database-delete-item"
(lambda ()
(fail-if-error
(lambda ()
(let ((db (make-database))
(data (string->byte-vector "hm")))
(open-database db (string-append (test-dir) "/bla.db")
(database-type binary-tree)
(list (flag create) (flag truncate)))
(database-put db data data)
(database-delete-item db data)
(close-database db)))
(lambda () #t))))
(add-test!
"database-truncate"
(lambda ()
(fail-if-error
(lambda ()
(let ((db (make-database)))
(open-database db (string-append (test-dir) "/bla.db")
(database-type binary-tree)
(list (flag create) (flag truncate)))
(database-truncate db)
(close-database db)))
(lambda () #t))))
(add-test!
"database-sync!"
(lambda ()
(fail-if-error
(lambda ()
(let ((db (make-database)))
(open-database db (string-append (test-dir) "/bla.db")
(database-type binary-tree)
(list (flag create) (flag truncate)))
(database-sync db)
(close-database db)))
(lambda () #t))))
(add-test!
"set-database-encrypt!"
(lambda ()
(fail-if-error
(lambda ()
(set-database-encrypt! (make-database) "geheim"))
(lambda () #t))))
(add-test!
"database-encrypt-flags"
(lambda ()
(let ((flags #f))
(fail-if-error
(lambda ()
(let ((db (make-database)))
(open-database db (string-append (test-dir) "/bla.db")
(database-type binary-tree)
(list (flag create) (flag truncate)))
(set! flags (database-encrypt-flags db))
(close-database db)))
(lambda ()
(integer? flags))))))
(add-test!
"set-database-flags!"
(lambda ()
(fail-if-error
(lambda ()
(let ((db (make-database)))
(open-database db (string-append (test-dir) "/bla.db")
(database-type binary-tree)
(list (flag create) (flag truncate)))
(set-database-flags! db (flag checksum))
(close-database db)))
(lambda () #t))))
(add-test!
"database-flags"
(lambda ()
(let ((flags #f))
(fail-if-error
(lambda ()
(let ((db (make-database)))
(open-database db (string-append (test-dir) "/bla.db")
(database-type binary-tree)
(list (flag create) (flag truncate)))
(set! flags (database-flags db))
(close-database db)))
(lambda ()
(integer? flags))))))
(define (run-tests)
(make-empty-test-dir)
(let lp ((tests *tests*))
(if (null? tests)
(display "Finished.\n")
(begin
(display "Testing ")
(display (caar tests))
(display "...")
(if ((cdar tests))
(begin
(display "ok\n")
(lp (cdr tests)))
(display "failed\n"))))))
(define (main args)
(run-tests))