The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl

use strict;
use warnings;

use Test::TempDir;
use Path::Class;
use Storable qw(nstore retrieve);
use Scalar::Util qw(blessed);
use Try::Tiny;

use KiokuDB;

# no long running tests
my $large = 0;

use Benchmark qw(cmpthese);

my $f = (require KiokuDB::Test::Fixture::ObjectGraph)->new;

sub construct {
    $f->create;
}

sub bench {
    my $dir = dir(tempdir);

    my $storable = $dir->file("foo.storable")->stringify;

    my $mxsd_hash = KiokuDB->connect("hash", serializer => "storable" );

    my $mxsd_files = KiokuDB->connect("files:dir=" . $dir->subdir("mxsd_files"), create => 1, global_lock => 1 );

    my $mxsd_bdb_txn = KiokuDB->connect("bdb:dir=" . $dir->subdir("mxsd_bdb_txn"), create => 1 );

    my $mxsd_sqlite = KiokuDB->connect("dbi:SQLite:dbname=" . $dir->file("sqlite.db"), serializer => "storable" );

    $mxsd_sqlite->backend->dbh->do("PRAGMA default_synchronous = OFF");

    $mxsd_sqlite->backend->deploy;

    my $mxsd_mysql = try { KiokuDB->connect("dbi:mysql:test", serializer => "storable") } catch  { warn @_ };
    $mxsd_mysql && $mxsd_mysql->backend->deploy({ add_drop_table => 1, producer_args => { mysql_version => 5 } });

    my $mxsd_pg = try { KiokuDB->connect("dbi:Pg:dbname=test", serializer => "storable") } catch { warn $@ };
    $mxsd_pg && $mxsd_pg->backend->deploy({ add_drop_table => 1 });

    $dir->subdir("mxsd_bdb_dumb")->mkpath;
    my $mxsd_bdb_dumb = KiokuDB->new(
        backend => KiokuDB::Backend::BDB->new(
            manager => {
                home => $dir->subdir("mxsd_bdb_dumb"),
                transactions => 0,
                create => 1,
            },
        ),
    );

    my $mxsd_couch;

    if ( my $uri = $ENV{KIOKU_COUCHDB_URI} ) {
        require KiokuDB::Backend::CouchDB;
        require AnyEvent::CouchDB;

        my $couch = AnyEvent::CouchDB::couch($uri);

        my $name = $ENV{KIOKU_COUCHDB_NAME} || "kioku-$$";

        my $db = $couch->db($name);
        try { $db->drop };

        $db->create;

        $mxsd_couch = KiokuDB->connect("couchdb:uri=$uri;db=$name");

        $mxsd_couch->{__guard} = Scope::Guard->new(sub { $db->drop });
    }

    warn "\nwriting...\n";

    $mxsd_bdb_txn->backend->txn_do(sub {
    $mxsd_files->backend->txn_do(sub {
        return;

        cmpthese(-3, {
            #null         => sub { my @objs = construct(); },
            mxsd_hash    => sub { my @objs = construct(); my $s = $mxsd_hash->new_scope; $mxsd_hash->store(grep { blessed($_) } @objs) },
            mxsd_files   => sub { my @objs = construct(); my $s = $mxsd_files->new_scope; $mxsd_files->store(grep { blessed($_) } @objs) },
            mxsd_bdb     => sub { my @objs = construct(); my $s = $mxsd_bdb_dumb->new_scope; $mxsd_bdb_dumb->store(grep { blessed($_) } @objs) },
            mxsd_bdb_txn => sub { my @objs = construct(); my $s = $mxsd_bdb_txn->new_scope; $mxsd_bdb_txn->store(grep { blessed($_) } @objs) },
            mxsd_sqlite  => sub { my @objs = construct(); my $s = $mxsd_sqlite->new_scope; $mxsd_sqlite->store(grep { blessed($_) } @objs) },
            ( $mxsd_mysql ? ( mxsd_mysql => sub { my @objs = construct(); my $s = $mxsd_mysql->new_scope; $mxsd_mysql->store(grep { blessed($_) } @objs) } ) : () ),
            ( $mxsd_pg    ? ( mxsd_pg    => sub { my @objs = construct(); my $s = $mxsd_pg->new_scope; $mxsd_pg->store(grep { blessed($_) } @objs) } ) : () ),
            ( $mxsd_couch ? ( mxsd_couch => sub { my @objs = construct(); my $s = $mxsd_couch->new_scope; $mxsd_couch->store(grep { blessed($_) } @objs) } ) : () ),
            storable   => sub { nstore([ construct() ], $storable) },
        });

    });
    });

    warn "\nreading...\n";

    nstore([ construct() ], $storable);
    my @hash_ids  = do { my @objs = construct(); my $s = $mxsd_hash->new_scope; $mxsd_hash->store(grep { blessed($_) } @objs) };
    my @files_ids = $mxsd_files->txn_do(sub { my @objs = construct(); my $s = $mxsd_files->new_scope; $mxsd_files->store(grep { blessed($_) } @objs) });
    my @bdb_d_ids = do { my @objs = construct(); my $s = $mxsd_bdb_dumb->new_scope; $mxsd_bdb_dumb->store(grep { blessed($_) } @objs) };
    my @bdb_t_ids = do { my @objs = construct(); my $s = $mxsd_bdb_txn->new_scope; $mxsd_bdb_txn->backend->txn_do(sub { $mxsd_bdb_txn->store(grep { blessed($_) } @objs) }); };
    my @sqlite_t_ids = do { my @objs = construct(); my $s = $mxsd_sqlite->new_scope; $mxsd_sqlite->backend->txn_do(sub { $mxsd_sqlite->store(grep { blessed($_) } @objs) }); };
    my @mysql_t_ids = $mxsd_mysql ? do { my @objs = construct(); my $s = $mxsd_mysql->new_scope; $mxsd_mysql->backend->txn_do(sub { $mxsd_mysql->store(grep { blessed($_) } @objs) }); } : ();
    my @pg_t_ids = $mxsd_pg ? do { my @objs = construct(); my $s = $mxsd_pg->new_scope; $mxsd_pg->backend->txn_do(sub { $mxsd_pg->store(grep { blessed($_) } @objs) }); } : ();
    my @couch_ids = $mxsd_couch ? do { my @objs = construct(); my $s = $mxsd_couch->new_scope; $mxsd_couch->store(grep { blessed($_) } @objs) } : ();

    cmpthese(-3, {
        storable     => sub { my $objs = retrieve($storable) },
        mxsd_hash    => sub { my $s = $mxsd_hash->new_scope; my @objs = $mxsd_hash->lookup(@hash_ids) },
        mxsd_files   => sub { my $s = $mxsd_files->new_scope; my @objs = $mxsd_files->lookup(@files_ids) },
        mxsd_bdb     => sub { my $s = $mxsd_bdb_dumb->new_scope; my @objs = $mxsd_bdb_dumb->lookup(@bdb_d_ids) },
        mxsd_bdb_txn => sub { my $s = $mxsd_bdb_txn->new_scope; my @objs = $mxsd_bdb_txn->lookup(@bdb_t_ids) },
        mxsd_sqlite  => sub { my $s = $mxsd_sqlite->new_scope; my @objs = $mxsd_sqlite->lookup(@sqlite_t_ids) },
        ( $mxsd_mysql ? ( mxsd_mysql   => sub { my $s = $mxsd_mysql->new_scope; my @objs = $mxsd_mysql->lookup(@mysql_t_ids) } ) : () ),
        ( $mxsd_pg    ? ( mxsd_pg      => sub { my $s = $mxsd_pg->new_scope; my @objs = $mxsd_pg->lookup(@pg_t_ids) } ) : () ),
        ( $mxsd_couch ? ( mxsd_couch => sub { my $s = $mxsd_couch->new_scope; my @objs = $mxsd_couch->lookup(@couch_ids) } ) : () ),
    });
}

bench();