view release on metacpan or  search on metacpan

t/entities.t  view on Meta::CPAN

        my $marker = $prefix ? ':'           : '';

        my $R = Game::Entities->new( prefix => $prefix );

        my ( $a, $b ) = map $R->create, 1 .. 2;

        is $R->check( $a, "${marker}Named" ), F,
            "A does not have ${base}Named";

        $R->add( $a, "${base}Named"->new( name => 'old' ) );
        $R->add( $a, "${base}Named"->new( name => 'new' ) );

        is $R->check( $a, "${marker}Named" ), T,
            "A has ${base}Named";

        if ( $prefix ) {
            is $R->check( $a,   'Named' ), F, 'No colon does not use prefix';
            is $R->check( $a, '::Named' ), F, 'Double colon does not use prefix';
        }

        is $R->check( $b, "${marker}Named" ), F,
            "B does not have ${base}Named";

        is $R->get( $a, "${marker}Named" )->name, 'new',
            'Adding component replaces';

        ref_is $R->delete( $a, "${marker}Named" ), $R;

        is $R->check( $a, "${marker}Named" ), F,
            "A does not have ${base}Named";

        $R->delete( $a, "${marker}Named" );

        is $R->check( $a, "${marker}Named" ), F,
            'Deleting is idempotent';

        is $R->get( $a, "${marker}Named" ), U,
            'Getting returns undef when no component';
    };
};

subtest 'Delete entities' => sub {
    my $R = Game::Entities->new;

    my $a = $R->create( Named->new( name => 'a' ), Other->new );

    ok $R->valid($a),          'A is valid';
    ok $R->get( $a, 'Other' ), 'A has Other';
    ok $R->get( $a, 'Named' ), 'A has Named';

    $R->delete($a);

    ok !$R->valid($a),          'A is not valid';
    ok !$R->get( $a, 'Other' ), 'A does not have Other';
    ok !$R->get( $a, 'Named' ), 'A does not have Named';
};

subtest 'Recycling GUIDs' => sub {
    my $R = Game::Entities->new;

    is $R->alive, 0, 'Right number of alive entities when none created';

    # Create 10 entities; will use the first 10 entity IDs ( 0 .. 9 )
    my @e = map $R->create, 1 .. 10;

    is  $R->alive, 10, 'Right number of alive entities when all alive';
    ok  $R->valid(10), 'Entity is valid';
    ok !$R->valid(11), 'Entity is not valid';

    # Delete the entities we've just generated
    # Will mark their IDs as ready to be recycled
    $R->delete($_) for @e;

    is  $R->created, 10, 'Created counts all created entities';
    is  $R->alive,    0, 'Right number of alive entities when all dead';
    ok !$R->valid(10),   'Entity is not valid';

    # Create 20 entities
    # They should re-use the first 10 IDs and use the next 10 ( 0 .. 19 )
    @e = map $R->create( Other->new ), 0 .. 19;
    is [ sort { $a <=> $b } map $_ & 0xFFFFF, @e ],
        [ 1 .. 20 ],
        'Recycled and generated the right IDs';

    ok $R->valid($e[8]), 'Entity is valid';
    is $R->alive, 20,    'Recorded the right number of alive entities after recycling';

    @e = $R->view('Other')->entities;
    is @e, 20, 'Only alive entities match view';

    $R->clear;
    is $R->alive,   0, 'Clear invalidates all entities';
    is $R->created, 0, 'No records remain';
};

subtest 'View' => sub {
    my $R = Game::Entities->new;

    my $named   = $R->create;
    my $aging   = $R->create;
    my $both    = $R->create;
    my $dead    = $R->create;
    my $reverse = $R->create;
    my $extra   = $R->create;

    $R->delete($dead);

    $R->add( $named   => Named->new( name => 'Pat'  ) );
    $R->add( $aging   => Aging->new( age  => 10     ) );

    $R->add( $both    => Aging->new( age  => 20     ) );
    $R->add( $both    => Named->new( name => 'Tim'  ) );

    $R->add( $reverse => Named->new( name => 'Mit'  ) );
    $R->add( $reverse => Aging->new( age  => 2      ) );

    $R->add( $extra   => Named->new( name => 'Most' ) );
    $R->add( $extra   => Aging->new( age  => 200    ) );
    $R->add( $extra   => Other->new                   );

    subtest 'Simple view' => sub {
        is [ sort map {
                    my $name = $R->get( $_, 'Named' );
                    $name ? $name->name : ();
                } $R->view('Named')->entities
            ],
            [qw( Mit Most Pat Tim )], 'entities';

        is [ sort map {
                    my ($name) = @$_;
                    $name ? $name->name : ();
                } $R->view('Named')->components
            ],
            [qw( Mit Most Pat Tim )], 'components';

        is [ sort map {
                    my ( $guid, $age ) = ( $_->[0], @{ $_->[1] } );
                    $age->age;
                } @{ $R->view('Aging') }
            ],
            [ 10, 2, 20, 200 ], 'deref';

        {
            my @first = $R->view('Aging')->first( sub { $_[1]->age > 100 } );
            is [ $first[0], $first[1]->age ], [ 6, 200 ],
                'first with match returns flat list';
        }

        {
            my @first = $R->view('Aging')->first;
            is [ $first[0], $first[1]->age ], [ 2, 10 ],
                'first with no matcher returns first element';

t/entities.t  view on Meta::CPAN

            $R->delete($e);
            $R->create( X->new( value => 11 ) );
            $R->create( Y->new( value => 11 ) );
        }
    });

    my @x;
    $R->view->each( sub ($e) {
        return unless my $x = $R->get( $e, 'X' );
        push @x, $x->value;
    });

    is [ sort @x ], [ 11, 6, 9 ], 'View can modify components';

    my @y;
    $R->view->each( sub ($e) {
        return unless my $y = $R->get( $e, 'Y' );
        push @y, $y->value;
    });

    is [ sort @y ], [ 10, 11, 7 ], 'Other component is left alone';

    $R->_dump_entities;
    like $R->_dump_entities, qr/SPARSE/, 'Generated dump';
};

subtest 'Component types' => sub {
    my $R = Game::Entities->new;

    subtest 'Good components' => sub {
        for (
            [ 'unblessed reference', 'HASH', {}  ],
            [ 'blessed reference',   'Other', Other->new ],
        ) {
            my ( $message, $type, $component ) = @$_;

            my $guid = $R->create( $component );
            is $R->get( $guid, $type ), $component, $message;

            $R->clear;
        }
    };

    subtest 'Bad components' => sub {
        for (
            [ 'undef',        undef ],
            [ 'plain scalar', 123   ],
        ) {
            my ( $message, $component ) = @$_;

            exception { $R->create( $component ) }
                qr/Component must be a reference/,
                "$message on create";

            my $guid = $R->create;

            exception { $R->add( $guid => $component ) }
                qr/Component must be a reference/,
                "$message on add";

            is $R->alive, 1, 'Did not create entities';
            $R->clear;
        }
    };

    subtest 'Components instead of names' => sub {
        my $guid = $R->create;
        for (
            [ undef => undef ],
            [ ref   => {}    ],
        ) {
            my ( $name, $input ) = @$_;

            exception { $R->check( $guid => $input ) }
                qr/Component name must be defined and not a reference/,
                "$name on check";

            exception { $R->get( $guid => $input ) }
                qr/Component name must be defined and not a reference/,
                "$name on get";
        }
    };

};

done_testing;