my %metaroles = (
+ base_class_roles => [ 'MooseX::UndefTolerant::Object' ],
class_metaroles => {
attribute => [ 'MooseX::UndefTolerant::Attribute' ],
}
Loading this module in your L<Moose> class makes initialization of your
attributes tolerant of undef. If you specify the value of undef to any of
the attributes they will not be initialized, effectively behaving as if you
-had not provided a value at all.
+had not provided a value at all. Such values are also cleaned from BUILDARGS.
You can also apply the 'UndefTolerant' trait to individual attributes. See
L<MooseX::UndefTolerant::Attribute> for details.
=head1 CAVEATS
This extension does not currently work in immutable classes when applying the
-trait to some (but not all) attributes in the class. This is because the
-inlined constructor initialization code currently lives in
+trait to a specific attributes in the class, as opposed to the class itself.
+This is because the inlined constructor initialization code currently lives in
L<Moose::Meta::Class>, not L<Moose::Meta::Attribute>. The good news is that
this is expected to be changing shortly.
+Also, BUILDARGS cannot be cleaned up if the entire class is not made undef
+tolerant, as attribute traits cannot modify class constructor behaviour.
+
=head1 ACKNOWLEDGEMENTS
Many thanks to the crew in #moose who talked me through this module:
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 / commitdiff