/usr/share/perl5/KiokuDB/Test/Fixture/Small.pm

package KiokuDB::Test::Fixture::Small;
BEGIN {
  $KiokuDB::Test::Fixture::Small::AUTHORITY = 'cpan:NUFFIN';
}
$KiokuDB::Test::Fixture::Small::VERSION = '0.57';
use Moose;

use Test::More;
use Test::Exception;

use Scalar::Util qw(refaddr);

use KiokuDB::Test::Person;
use KiokuDB::Test::Employee;
use KiokuDB::Test::Company;

sub p;

use namespace::clean -except => 'meta';

sub p {
    my @args = @_;
    unshift @args, "name" if @args % 2;
    KiokuDB::Test::Person->new(@args);
}

with qw(KiokuDB::Test::Fixture) => { -excludes => [qw/populate sort/] };

sub sort { -100 }

has [qw(joe oscar)] => (
    isa => "Str",
    is  => "rw",
);

sub create {
    return (
        KiokuDB::Test::Employee->new(
            name    => "joe",
            age     => 52,
            parents => [ KiokuDB::Test::Person->new(
                name => "mum",
                age  => 78,
            ) ],
            company => KiokuDB::Test::Company->new(
                name => "OHSOME SOFTWARE KTHX"
            ),
        ),
        KiokuDB::Test::Person->new(
            name => "oscar",
            age => 3,
        ),
    );
}

sub populate {
    my $self = shift;

    {
        my $s = $self->new_scope;

        my ( $joe, $oscar ) = $self->create;

        isa_ok( $joe, "KiokuDB::Test::Person" );
        isa_ok( $joe, "KiokuDB::Test::Employee" );

        isa_ok( $oscar, "KiokuDB::Test::Person" );

        my ( $joe_id, $oscar_id ) = $self->store_ok($joe, $oscar);

        $self->joe($joe_id);
        $self->oscar($oscar_id);

        $self->live_objects_are($joe, $joe->company, @{ $joe->parents }, $oscar);
    }

    $self->no_live_objects;
}

sub verify {
    my $self = shift;

    $self->txn_lives(sub {
        my ( $joe, $oscar ) = my @objs = $self->lookup_ok( $self->joe, $self->oscar );

        isa_ok( $joe, "KiokuDB::Test::Person" );
        isa_ok( $joe, "KiokuDB::Test::Employee" );

        isa_ok( $oscar, "KiokuDB::Test::Person" );

        my $entry = $self->directory->live_objects->object_to_entry($joe);

        ok( $entry->has_object, "entry is associated with object" );

        is( refaddr($entry->object), refaddr($joe), "the right object" );

        is( $joe->name, "joe", "name" );

        ok( my $parents = $joe->parents, "parents" );

        is( ref($parents), "ARRAY", "array ref" );

        is( scalar(@$parents), 1, "one parent" );

        isa_ok( $parents->[0], "KiokuDB::Test::Person" );

        is( $parents->[0]->name, "mum", "parent name" );

        ok( my $company = $joe->company, "company" );

        isa_ok( $company, "KiokuDB::Test::Company" );

        is( $oscar->name, "oscar", "name" );

        lives_ok { $self->directory->lookup("no_such_id") } "lookup of nonexistent ID is nonfatal";
    });
}
__PACKAGE__

__END__

=pod

=encoding UTF-8

=head1 NAME

KiokuDB::Test::Fixture::Small

=head1 VERSION

version 0.57

=head1 AUTHOR

Yuval Kogman <nothingmuch@woobling.org>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2014 by Yuval Kogman, Infinity Interactive.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut
libkiokudb-perl 0.57-1 / usr / share / perl5 / KiokuDB / Test / Fixture / Small.pm
