t/directory.t - metacpan.org

#!/usr/bin/perl

use strict;
use warnings;

use Test::More;
use Test::Exception;
use Try::Tiny;

BEGIN { eval 'use Test::Memory::Cycle; 1' or eval 'sub memory_cycle_ok { SKIP: { skip "Test::Memory::Cycle missing", 1 }}' }

use Scalar::Util qw(blessed weaken isweak refaddr);

BEGIN { $KiokuDB::SERIAL_IDS = 1 }

use ok 'KiokuDB';
use ok 'KiokuDB::Backend::Hash';

sub no_live_objects {
    local $Test::Builder::Level = $Test::Builder::Level + 1;

    our $dir;

    is_deeply(
        [ $dir->live_objects->live_objects ],
        [],
        "live object set is empty",
    );

    is_deeply(
        [ $dir->live_objects->live_entries ],
        [],
        "live entry set is empty",
    );

    if ( my @entries = $dir->live_objects->live_entries ) {
        $dir->live_objects->clear;
        diag Devel::FindRef::track($entries[0], 100);
        $entries[0]{__destroyed} = Scope::Guard->new(sub { Carp::cluck("finally destroyed") });
        diag($dir->live_objects->dump);
    }
}

{
    package KiokuDB_Test_Foo;
    use Moose;

    our $VERSION = "0.02";

    has foo => (
        isa => "Str",
        is  => "rw",
    );

    has bar => (
        is => "rw",
    );

    has parent => (
        is  => "rw",
        weak_ref => 1,
    );

    __PACKAGE__->meta->make_immutable;
}

foreach my $keep_entries ( 1, 0 ) {
our $dir = KiokuDB->new(
    live_objects => {
        keep_entries => $keep_entries,
    },
    check_class_versions => 1,
    class_version_table => {
        KiokuDB_Test_Foo => {
            "0.01" => {
                class_version => "0.02",
                data          => { foo => "upgraded" },
            },
        },
    },
    backend => KiokuDB::Backend::Hash->new,
    #backend => KiokuDB::Backend::JSPON->new(
    #    dir    => temp_root,
    #    pretty => 1,
    #    lock   => 0,
    #),
);


my $l = $dir->live_objects;

# Pixie ain't got nuthin on us
my $id;

{
    my $s = $dir->new_scope;

    my $x = KiokuDB_Test_Foo->new(
        foo => "dancing",
        bar => KiokuDB_Test_Foo->new(
            foo => "oh",
        ),
    );

    memory_cycle_ok($x, "no cycles in proto obj" );

    $x->bar->parent($x);

    memory_cycle_ok($x, "cycle is weak");

    memory_cycle_ok($s, "no cycles in scope");
    memory_cycle_ok($l, "no cycles in live objects");

    $id = $dir->store($x);

    memory_cycle_ok($s, "no cycles in scope");
    memory_cycle_ok($l, "no cycles in live objects");

    if ( $keep_entries ) {
        my $entry = $l->object_to_entry($x);

        ok( $entry, "got an entry for $id" );

        is( try { $entry->id }, $id, "with the right entry" );

        is( try { $entry->object }, $x, "and the right object" );
    } else {
        is( $l->object_to_entry($x), undef, "no entry" );
    }


    memory_cycle_ok($x, "store did not introduce cycles");

    is_deeply(
        [ sort $l->live_objects ],
        [ sort $x, $x->bar ],
        "live object set"
    );
};

no_live_objects;

memory_cycle_ok($l, "no cycles in live objects");

my $weak;

{
    my $s = $dir->new_scope;

    my $obj = $dir->lookup($id);

    weaken($weak = $obj);

    memory_cycle_ok($obj, "no cycles in object");

    memory_cycle_ok($s, "no cycles in scope");
    memory_cycle_ok($l, "no cycles in live objects");

    is( $obj->foo, "dancing", "simple attr" );
    isa_ok( $obj->bar, "KiokuDB_Test_Foo", "object attr" );
    is( $obj->bar->foo, "oh", "simple attr of sub object" );
    isa_ok( $obj->bar->parent, "KiokuDB_Test_Foo", "object attr of sub object" );
    is( $obj->bar->parent, $obj, "circular ref" );
}

is( $weak, undef, "weak ref to object died" );

no_live_objects;

memory_cycle_ok($l, "no cycles in live objects");

{
    my $s = $dir->new_scope;

    my $x = KiokuDB_Test_Foo->new(
        foo => "oink oink",
        bar => my $y = KiokuDB_Test_Foo->new(
            foo => "yay",
        ),
    );

    my @ids = $dir->store($x, $y);

    is( scalar(@ids), 2, "got two ids" );

    $s->clear;

    undef $x;

    is( $l->id_to_object($ids[0]), undef, "first object is dead" );
    is( $l->id_to_object($ids[1]), $y, "second is still alive" );

    {
        my $s = $dir->new_scope;
        my @objects = map { $dir->lookup($_) } @ids;

        isa_ok( $objects[0], "KiokuDB_Test_Foo" );
        is( $objects[0]->foo, "oink oink", "object retrieved" );
        is( $objects[1], $y, "object is already live" );
        is( $objects[0]->bar, $y, "link recreated" );
    }
}

no_live_objects;

{
    my $s = $dir->new_scope;

    my @ids = do{
        my $s = $dir->new_scope;

        my $shared = KiokuDB_Test_Foo->new( foo => "shared" );

        my $first  = KiokuDB_Test_Foo->new( foo => "first",  bar => $shared );
        my $second = KiokuDB_Test_Foo->new( foo => "second", bar => $shared );

        $dir->store( $first, $second );
    };

    no_live_objects;

    my $first = $dir->lookup($ids[0]);

    isa_ok( $first, "KiokuDB_Test_Foo" );
    is( $first->foo, "first", "normal attr" );
    isa_ok( $first->bar, "KiokuDB_Test_Foo", "shared object" );
    is( $first->bar->foo, "shared", "normal attr of shared" );

    my $second = $dir->lookup($ids[1]);

    isa_ok( $second, "KiokuDB_Test_Foo" );
    is( $second->foo, "second", "normal attr" );

    is( $second->bar, $first->bar, "shared object" );
}

no_live_objects;

{
    my $s = $dir->new_scope;

    my @ids = do{
        my $s = $dir->new_scope;

        my $shared = { foo => "shared", object => KiokuDB_Test_Foo->new( foo => "shared child" ) };

        $shared->{object}->parent($shared);

        my $first  = KiokuDB_Test_Foo->new( foo => "first",  bar => $shared );
        my $second = KiokuDB_Test_Foo->new( foo => "second", bar => $shared );

        $dir->store( $first, $second );
    };

    no_live_objects;

    my $first = $dir->lookup($ids[0]);

    isa_ok( $first, "KiokuDB_Test_Foo" );
    is( $first->foo, "first", "normal attr" );

    is( ref($first->bar), "HASH", "shared hash" );
    is( $first->bar->{foo}, "shared", "hash data" );

    isa_ok( $first->bar->{object}, "KiokuDB_Test_Foo", "indirect shared child" );

    my $second = $dir->lookup($ids[1]);

    isa_ok( $second, "KiokuDB_Test_Foo" );
    is( $second->foo, "second", "normal attr" );

    is( $second->bar, $first->bar, "shared value" );
}

no_live_objects;

{
    my $s = $dir->new_scope;

    my $id = do{
        my $s = $dir->new_scope;

        my $shared = { foo => "hippies" };

        weaken($shared->{self} = $shared);

        $dir->store( KiokuDB_Test_Foo->new( foo => "blimey", bar => $shared ) );
    };

    no_live_objects;

    my $obj = $dir->lookup($id);

    isa_ok( $obj, "KiokuDB_Test_Foo" );
    is( $obj->foo, "blimey", "normal attr" );

    is( ref($obj->bar), "HASH", "shared hash" );
    is( $obj->bar->{foo}, "hippies", "hash data" );
    is( $obj->bar->{self}, $obj->bar, "circular ref" );

    ok( isweak($obj->bar->{self}), "weak ref" );
}

no_live_objects;


{
    my $s = $dir->new_scope;

    my $id = $dir->insert( KiokuDB_Test_Foo->new( foo => "henry" ) );
    ok( $id, "insert returns ID for new object" );

    $s->clear;

    no_live_objects;

    my $obj = $dir->lookup($id);

    is( $obj->foo, "henry", "stored by insert" );

    throws_ok {
        $dir->insert($obj)
    } qr/already in database/i, "insertion of present object is an error";
}

no_live_objects;


{
    my $id = do {
        my $s = $dir->new_scope;
        $dir->store( KiokuDB_Test_Foo->new( foo => "blimey" ) );
    };

    no_live_objects;

    {
        my $s = $dir->new_scope;

        my $obj = $dir->lookup($id);

        isa_ok( $obj, "KiokuDB_Test_Foo" );
        is( $obj->foo, "blimey", "normal attr" );

        $obj->foo("fancy");

        is( $obj->foo, "fancy", "attr changed" );
    }

    no_live_objects;

    {
        my $s = $dir->new_scope;

        my $obj = $dir->lookup($id);

        isa_ok( $obj, "KiokuDB_Test_Foo" );
        is( $obj->foo, "blimey", "change not saved" );

        $obj->foo("pancy");

        is( $obj->foo, "pancy", "attr changed" );

        throws_ok {
            $dir->insert($obj)
        } qr/already in database/i, "insertion of present object is an error";
    }

    no_live_objects;

    {
        my $s = $dir->new_scope;

        my $obj = $dir->lookup($id);

        isa_ok( $obj, "KiokuDB_Test_Foo" );
        is( $obj->foo, "blimey", "change not saved" );

        $obj->foo("shmancy");

        is( $obj->foo, "shmancy", "attr changed" );

        is( $dir->store($obj), $id, "ID" );
    }

    no_live_objects;

    {
        my $s = $dir->new_scope;

        my $obj = $dir->lookup($id);

        isa_ok( $obj, "KiokuDB_Test_Foo" );
        is( $obj->foo, "shmancy", "store saved change" );

        is( $obj->bar, undef, "no 'bar' attr" );

        $obj->bar( KiokuDB_Test_Foo->new( foo => "child" ) );

        is( $dir->store($obj), $id, "ID" );
    }

    no_live_objects;

    {
        my $s = $dir->new_scope;

        my $child;

        {
            my $s = $dir->new_scope;

            my $obj = $dir->lookup($id);

            isa_ok( $obj, "KiokuDB_Test_Foo" );

            isa_ok( $obj->bar, "KiokuDB_Test_Foo" );

            is( $obj->bar->foo, "child", "child object's attr" );

            $child = $obj->bar;
        }

        is_deeply(
            [ $l->live_objects ],
            [ $child ],
            "only child in live object set",
        );


        {
            my $s = $dir->new_scope;

            my $obj = $dir->lookup($id);

            isa_ok( $obj, "KiokuDB_Test_Foo" );

            isa_ok( $obj->bar, "KiokuDB_Test_Foo" );

            is( $obj->bar->foo, "child", "child object's attr" );

            is( refaddr($obj->bar), refaddr($child), "same refaddr as live object" );

            is_deeply(
                [ sort $l->live_objects ],
                [ sort $child, $obj ],
                "two objects in live object set",
            );

            $obj->bar( KiokuDB_Test_Foo->new( foo => "third" ) );

            $dir->store( $obj->bar );
        }

        {
            my $s = $dir->new_scope;

            my $obj = $dir->lookup($id);

            isa_ok( $obj, "KiokuDB_Test_Foo" );

            isa_ok( $obj->bar, "KiokuDB_Test_Foo" );

            is( $obj->bar->foo, "child", "child object's attr unchanged" );

            is( refaddr($obj->bar), refaddr($child), "same refaddr as live object" );

            $obj->bar( KiokuDB_Test_Foo->new( foo => "third" ) );

            $dir->store( $obj );
        }

        {
            my $s = $dir->new_scope;

            my $obj = $dir->lookup($id);

            isa_ok( $obj, "KiokuDB_Test_Foo" );

            isa_ok( $obj->bar, "KiokuDB_Test_Foo" );

            isnt( refaddr($obj->bar), refaddr($child), "same refaddr as live object" );

            is( $obj->bar->foo, "third", "child inserted due to parent's update" );

            $dir->store( $obj );
        }
    }
}

no_live_objects;


{
    my $id = do {
        my $s = $dir->new_scope;
        $dir->insert( KiokuDB_Test_Foo->new( foo => "hippies" ) );
    };

    ok( $id, "insert returns ID for new object" );

    no_live_objects;

    {
        my $s = $dir->new_scope;

        my $obj = $dir->lookup($id);

        is( $obj->foo, "hippies", "stored by insert" );

        $obj->foo("blah");
    }

    no_live_objects;

    {
        my $s = $dir->new_scope;

        my $obj = $dir->lookup($id);

        is( $obj->foo, "hippies", "not updated" );

        $obj->foo("goddamn");

        my $entry;
        if ( $keep_entries ) {
            $entry = $l->object_to_entry($obj);

            ok( $entry, "got an entry" );

            is( $entry->id, $id, "right id" );
        } else {
            $entry = $l->object_to_entry($obj);
            is( $entry, undef, "no entry" ) or diag(Devel::FindRef::track($entry, 100));
        }

        $dir->update($obj);

        if ( $keep_entries ) {
            my $update_entry = $l->object_to_entry($obj);

            ok( $update_entry, "got an update entry" );

            is( $update_entry->id, $id, "right id" );

            is( $update_entry->prev, $entry, "prev entry" );
        } else {
            is( $l->object_to_entry($obj), undef, "no entry" );
        }
    }

    no_live_objects;

    my $child = KiokuDB_Test_Foo->new( foo => "meddling kids" );

    {
        my $s = $dir->new_scope;

        my $obj = $dir->lookup($id);

        is( $obj->foo, "goddamn", "updated" );

        $obj->bar( $child );

        $@ = "";
        try {
            $dir->update($obj);
            fail("expected error");
        } catch {
            is_deeply( $_, KiokuDB::Error::UnknownObjects->new( objects => [ $child ] ), "update with a partial object" );
        };

        $dir->insert($child);

        ok( $l->object_to_id($child), "child has ID now" );

        ok( $l->object_in_storage($child), "its in storage" );

        if ( $keep_entries ) {
            isa_ok( $l->object_to_entry($child), "KiokuDB::Entry" );
        } else {
            is( $l->object_to_entry($child), undef, "KiokuDB::Entry" );
        }

        lives_ok { $dir->update($obj) } "no error this time";
    }

    {
        my $s = $dir->new_scope;

        my $obj = $dir->lookup($id);

        is( $obj->bar, $child, "updated" );

        undef $child;

        $obj->bar->foo("OH HAI");

        $dir->update( $obj );
    }

    no_live_objects;

    {
        my $s = $dir->new_scope;

        my $obj = $dir->lookup($id);

        is( $obj->bar->foo, "meddling kids", "update is shallow" );

        $obj->bar->foo("three");

        $dir->update( $obj->bar );
    }

    no_live_objects;

    {
        my $s = $dir->new_scope;

        my $obj = $dir->lookup($id);

        is( $obj->bar->foo, "three", "updated" );
    }
}

no_live_objects;

{
    my $s = $dir->new_scope;

    my $id = do {
        my $s = $dir->new_scope;

        $dir->store(
            KiokuDB_Test_Foo->new(
                foo => "dancing",
                bar => KiokuDB_Test_Foo->new(
                    foo => "oh",
                ),
            ),
        );
    };

    no_live_objects;

    {
        my $s = $dir->new_scope;
        isa_ok( $dir->lookup($id), "KiokuDB_Test_Foo" );
    }

    no_live_objects;

    $dir->delete($id);

    no_live_objects;

    is( $dir->lookup($id), undef, "deleted" );
};

no_live_objects;

{
    my $s = $dir->new_scope;

     my $id = $dir->store(
        my $foo = KiokuDB_Test_Foo->new(
            foo => "dancing",
            bar => my $bar = KiokuDB_Test_Foo->new(
                foo => "oh",
            ),
        ),
    );

    if ( $keep_entries ) {
        my @entries = $l->objects_to_entries($foo, $bar);

        is( scalar(@entries), 2, "two entries" );
        is( $entries[0]->object, $foo, "entry object" );
        is( $entries[1]->object, $bar, "entry object" );

        $dir->delete($foo, $bar);

        is( $l->object_to_entry($foo), undef, "no entry object" );
        is( $l->object_to_entry($bar), undef, "no entry object" );
    } else {
        is_deeply( [ $l->live_entries ], [ ], "no live entries" );
    }
};

no_live_objects;

{
    my $s = $dir->new_scope;

    my $id = $dir->store(
        blah => my $foo = KiokuDB_Test_Foo->new( foo => "dancing" ),
    );

    is( $id, "blah", "custom id" );

    is( $l->object_to_id($foo), "blah", "object to id" );

    if ( $keep_entries ) {
        isa_ok( my $entry = $l->object_to_entry($foo), "KiokuDB::Entry" );
        ok( $entry->root, "root object" );
    } else {
        is( $l->object_to_entry($foo), undef, "no entry" );
    }

    ok( $dir->is_root($foo), "object is in root set" );
};

no_live_objects;

{
    my $s = $dir->new_scope;

    my $id = $dir->insert_nonroot(
        nonroot_object => my $foo = KiokuDB_Test_Foo->new( foo => "lala" ),
    );

    is( $id, "nonroot_object", "custom id" );

    is( $l->object_to_id($foo), "nonroot_object", "object to id" );

    if ( $keep_entries ) {
        isa_ok( my $entry = $l->object_to_entry($foo), "KiokuDB::Entry" );
        ok( !$entry->root, "not root" );
    } else {
        is( $l->object_to_entry($foo), undef, "no entry" );
    }

    ok( !$dir->is_root($foo), "object is not in root set" );
};

no_live_objects;

{
    {
        my $s = $dir->new_scope;

        my $id = $dir->insert( KiokuDB_Test_Foo->new( foo => "blah blah" ) );

        my ( $entry ) = $dir->backend->get($id);

        my $old_entry = $entry->clone(
            class_version => "0.01",
            id            => "old_object",
        );

        $dir->backend->insert($old_entry);
    }

    {
        my $s = $dir->new_scope;

        my $obj = $dir->lookup("old_object");

        isa_ok( $obj, "KiokuDB_Test_Foo" );

        is( $obj->foo, "upgraded", "field upgraded" );
    }
};

no_live_objects;

}

done_testing;
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)