use strict;
use warnings;
use Test::More;
use Test::Fatal;
use Test::Moose qw( with_immutable );
use Test::Deep;
{
package Standard;
use Moose;
has thing => ( is => 'rw' );
}
{
package Slurpier;
use Moose;
use MooseX::SlurpyConstructor;
has thing => ( is => 'rw' );
has slurpy => ( is => 'ro', slurpy => 1 );
}
{
package Subclass;
use Moose;
use MooseX::SlurpyConstructor;
extends 'Slurpier';
has size => ( is => 'rw' );
}
{
package SlurpySubclass;
use Moose;
extends 'Slurpier';
has size => ( is => 'rw' );
}
{
package OtherSlurpySubclass;
use Moose;
use MooseX::SlurpyConstructor;
extends 'Standard';
has size => ( is => 'rw' );
has slurpy => ( is => 'ro', slurpy => 1 );
}
{
package Tricky;
use Moose;
use MooseX::SlurpyConstructor;
has thing => ( is => 'rw' );
has slurpy => ( is => 'ro', slurpy => 1 );
sub BUILD {
my $self = shift;
my $params = shift;
delete $params->{spy};
}
}
{
package InitArg;
use Moose;
use MooseX::SlurpyConstructor;
has thing => ( is => 'rw', init_arg => 'other' );
has size => ( is => 'rw', init_arg => undef );
has slurpy => ( is => 'ro', slurpy => 1 );
}
my @classes = qw( Standard Slurpier Subclass SlurpySubclass OtherSlurpySubclass Tricky InitArg );
with_immutable {
my $obj;
is(
exception { $obj = Standard->new( thing => 1, bad => 99 ) }, undef,
'standard Moose class ignores unknown params',
);
undef $obj;
is(
exception { $obj = Slurpier->new( thing => 1, bad => 99 ) },
undef,
'slurpy constructor doesn\'t die on unknown params',
);
cmp_deeply($obj->slurpy, { bad => 99 }, 'slurpy attr grabs unknown param');
undef $obj;
is(
exception { $obj = Subclass->new( thing => 1, size => 'large' ) }, undef,
'subclass constructor handles unknown attributes correctly',
);
is(
exception { $obj = Subclass->new( thing => 1, bad => 98 ) },
undef,
'subclass correctly slurps unknown attribute',
);
cmp_deeply($obj->slurpy, { bad => 98 }, 'slurpy attr grabs unknown param');
undef $obj;
is(
exception { $obj = SlurpySubclass->new( thing => 1, size => 'large', ) }, undef,
'subclass that doesn\'t use slurpy constructor handles known attributes correctly',
);
is(
exception { $obj = SlurpySubclass->new( thing => 1, bad => 98 ) },
undef,
'subclass that doesn\'t use slurpy correctly slurps unknown attribute',
);
cmp_deeply($obj->slurpy, { bad => 98 }, 'slurpy attr grabs unknown param');
undef $obj;
is(
exception { $obj = OtherSlurpySubclass->new( thing => 1, size => 'large', ) }, undef,
'slurpy subclass from parent that doesn\'t use slurpy constructor handles known attributes correctly',
);
is(
exception { $obj = OtherSlurpySubclass->new( thing => 1, bad => 99 ) }, undef,
'slurpy subclass from parent that doesn\'t use slurpy correctly recognizes bad attribute',
);
cmp_deeply($obj->slurpy, { bad => 99 }, 'slurpy attr grabs unknown param');
undef $obj;
is(
exception { $obj = Tricky->new( thing => 1, spy => 99 ) }, undef,
'can work around slurpy constructor by deleting params in BUILD()',
);
cmp_deeply($obj->slurpy, undef, 'slurpy attr had nothing to grab');
is(
exception { $obj = Tricky->new( thing => 1, agent => 99 ) },
undef,
'Tricky still grabs unknown params other than spy',
);
cmp_deeply($obj->slurpy, { agent => 99 }, 'slurpy attr had nothing to grab');
undef $obj;
$obj = InitArg->new( thing => 1 );
cmp_deeply($obj->slurpy, { thing => 1 }, 'slurpy attr grabs unknown param');
# TODO: consider whether this is the right thing to do
$obj = InitArg->new( size => 1 );
cmp_deeply($obj->slurpy, { size => 1 }, 'slurpy attr grabs attr with undef init_arg');
is(
exception { $obj = InitArg->new( other => 1 ) }, undef,
'InitArg works when given proper init_arg',
);
}
@classes;
done_testing();