ConstructorTests;
{
- package Foo;
+ 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',
}
{
- package Bar;
+ 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',
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
{
'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');
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) },
'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 '
{
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');
'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');
projects / gitmo/MooseX-UndefTolerant.git / blobdiff