clean undef-tolerant and undefined args in BUILDARGS

[gitmo/MooseX-UndefTolerant.git] / t / lib / ConstructorTests.pm

package # hide from PAUSE
    ConstructorTests;

{
    package # hide from PAUSE
        Base;
    use Moose;

    # save a before and after copy of arguments for later testing.
    has $_ => (
        isa => 'HashRef',
        writer => '_set_' . $_,
        lazy => 1,
        default => sub { die 'in default' },
        traits => ['Hash'],
        handles => { $_ => 'elements' },
    ) foreach (qw(args_orig args_final));
    around BUILDARGS => sub {
        my $orig  = shift;
        my $class = shift;

        my %original_args = @_;
        my $args = $class->$orig(@_);
        return {
            %$args,
            args_orig => \%original_args,
        };
    };

    # we save the final arg list here rather than in BUILDARGS, as we can't guarantee
    # the order of role application in the two method modifications of
    # BUILDARGS (here, and in MooseX::UndefTolerant::Object)
    sub BUILD
    {
        my ($self, $args) = @_;
        my %args = %$args;
        delete $args{args_orig};
        $self->_set_args_final(\%args);
    }
}

{
    package # hide from PAUSE
        Foo;
    use Moose;
    extends 'Base';

    # attrs that did not like undefs until we applied this trait
    our @newly_tolerant_attrs = qw(attr1);
    has 'attr1' => (
        traits => [ qw(MooseX::UndefTolerant::Attribute)],
        is => 'ro',
        isa => 'Num',
        predicate => 'has_attr1',
    );
    has 'attr2' => (
        is => 'ro',
        isa => 'Num',
        predicate => 'has_attr2',
    );
    has 'attr3' => (
        is => 'ro',
        isa => 'Maybe[Num]',
        predicate => 'has_attr3',
    );
}

{
    package # hide from PAUSE
        Bar;
    use Moose;

    extends 'Base';
    use MooseX::UndefTolerant;

    # attrs that did not like undefs until we applied this trait
    our @newly_tolerant_attrs = qw(attr1 attr2);
    has 'attr1' => (
        is => 'ro',
        isa => 'Num',
        predicate => 'has_attr1',
    );
    has 'attr2' => (
        is => 'ro',
        isa => 'Num',
        predicate => 'has_attr2',
    );
    has 'attr3' => (
        is => 'ro',
        isa => 'Maybe[Num]',
        predicate => 'has_attr3',
    );
}

package # hide from PAUSE
    ConstructorTests;

use strict;
use warnings;

use Test::More;
use Test::Fatal;
use Scalar::Util 'blessed';
use List::MoreUtils 'any';

# checks all values passing through BUILDARGS to confirm they were handled
# appropriately:
# - defined fields left alone
# - undefined fields cleaned iff the type constraint would fail and has the
#   UndefTolerant trait
sub attrs_cleaned
{
    my $obj = shift;

    no strict 'refs';
    my @newly_tolerant_attrs = @{blessed($obj) . '::newly_tolerant_attrs'};
    my %original_args = $obj->args_orig;
    my %final_args = $obj->args_final;

    foreach my $attr (qw(attr1 attr2 attr3))
    {
        local $TODO;
        $TODO = 'BUILDARGS cannot be cleaned if the entire class is not undef-tolerant; see CAVEATS'
            if $obj->meta->is_mutable and not $obj->does('MooseX::UndefTolerant::Class')
            and exists $original_args{$attr}
            and not defined $original_args{$attr}
            and any { $_ eq $attr } @newly_tolerant_attrs;

        is(
            # actual state of arg after passing through BUILDARGS
            !exists($final_args{$attr})
                ? 'not passed'
                : defined($final_args{$attr})
                ? 'defined'
                : 'undefined',
            # expected state of arg after passing through BUILDARGS
            do {
                !exists($original_args{$attr})
                    ? 'not passed'
                    : defined($original_args{$attr})
                    ? 'defined'
                    : (any { $_ eq $attr } @newly_tolerant_attrs)
                    ? 'not passed'    # these attrs were cleaned out
                    : 'undefined';
            },
            'constructor argument "' . $attr . '" is updated appropriately in BUILDARGS',
        );
    }
}

sub do_tests
{
    note 'Testing ', (Foo->meta->is_immutable ? 'im' : '') . 'mutable ',
        'class with a single UndefTolerant attribute';
    {
        my $obj = Foo->new;
        attrs_cleaned($obj);
        ok(!$obj->has_attr1, 'attr1 has no value before it is assigned');
        ok(!$obj->has_attr2, 'attr2 has no value before it is assigned');
        ok(!$obj->has_attr3, 'attr3 has no value before it is assigned');
    }

    TODO: {
        local $TODO;
        $TODO = 'some immutable cases are not handled yet; see CAVEATS' if Foo->meta->is_immutable;
        is(
            exception {
                my $obj = Foo->new(attr1 => undef);
                attrs_cleaned($obj);

                ok(!$obj->has_attr1, 'UT attr1 has no value when assigned undef in constructor');
                like(
                    exception { $obj = Foo->new(attr2 => undef) },
                    qr/\QAttribute (attr2) does not pass the type constraint because: Validation failed for 'Num' with value undef\E/,
                    'But assigning undef to attr2 generates a type constraint error');

                is (exception { $obj = Foo->new(attr3 => undef) }, undef,
                    'assigning undef to attr3 is acceptable');
                ok($obj->has_attr3, 'attr3 still has a value');
                is($obj->attr3, undef, '...which is undef, when assigned undef in constructor');
                attrs_cleaned($obj);
            },
            undef,
            'successfully tested spot-application of UT trait in '
                . (Foo->meta->is_immutable ? 'im' : '') . 'mutable classes',
        );
    }

    {
        my $obj = Foo->new(attr1 => 1234, attr2 => 5678, attr3 => 9012);
        attrs_cleaned($obj);
        is($obj->attr1, 1234, 'assigning a defined value during construction works as normal');
        ok($obj->has_attr1, '...and the predicate returns true as normal');

        is($obj->attr2, 5678, 'assigning a defined value during construction works as normal');
        ok($obj->has_attr2, '...and the predicate returns true as normal');

        is($obj->attr3, 9012, 'assigning a defined value during construction works as normal');
        ok($obj->has_attr3, '...and the predicate returns true as normal');
    }

    note '';
    note 'Testing class with the entire ',
        (Bar->meta->is_immutable ? 'im' : '') . 'mutable ',
        'class being UndefTolerant';
    {
        my $obj = Bar->new;
        attrs_cleaned($obj);
        ok(!$obj->has_attr1, 'attr1 has no value before it is assigned');
        ok(!$obj->has_attr2, 'attr2 has no value before it is assigned');
        ok(!$obj->has_attr3, 'attr3 has no value before it is assigned');
    }

    {
        my $obj = Bar->new(attr1 => undef);
        attrs_cleaned($obj);
        ok(!$obj->has_attr1, 'attr1 has no value when assigned undef in constructor');
        # note this test differs from the Foo case above
        is (exception { $obj = Bar->new(attr2 => undef) }, undef,
            'assigning undef to attr2 does not produce an error');
        attrs_cleaned($obj);
        ok(!$obj->has_attr2, 'attr2 has no value when assigned undef in constructor');

        is( exception { $obj = Bar->new(attr3 => undef) }, undef,
            'assigning undef to attr3 is acceptable');
        ok($obj->has_attr3, 'attr3 still has a value');
        is($obj->attr3, undef, '...which is undef, when assigned undef in constructor');
        attrs_cleaned($obj);
    }

    {
        my $obj = Bar->new(attr1 => 1234, attr2 => 5678, attr3 => 9012);
        attrs_cleaned($obj);
        is($obj->attr1, 1234, 'assigning a defined value during construction works as normal');
        ok($obj->has_attr1, '...and the predicate returns true as normal');

        is($obj->attr2, 5678, 'assigning a defined value during construction works as normal');
        ok($obj->has_attr2, '...and the predicate returns true as normal');

        is($obj->attr3, 9012, 'assigning a defined value during construction works as normal');
        ok($obj->has_attr3, '...and the predicate returns true as normal');
    }
}

1;