1 package # hide from PAUSE
5 package # hide from PAUSE
9 # save a before and after copy of arguments for later testing.
12 writer => '_set_' . $_,
14 default => sub { die 'in default' },
16 handles => { $_ => 'elements' },
17 ) foreach (qw(args_orig args_final));
18 around BUILDARGS => sub {
22 my %original_args = @_;
23 my $args = $class->$orig(@_);
26 args_orig => \%original_args,
30 # we save the final arg list here rather than in BUILDARGS, as we can't guarantee
31 # the order of role application in the two method modifications of
32 # BUILDARGS (here, and in MooseX::UndefTolerant::Object)
35 my ($self, $args) = @_;
37 delete $args{args_orig};
38 $self->_set_args_final(\%args);
43 package # hide from PAUSE
48 # attrs that did not like undefs until we applied this trait
49 our @newly_tolerant_attrs = qw(attr1);
51 traits => [ qw(MooseX::UndefTolerant::Attribute)],
54 predicate => 'has_attr1',
59 predicate => 'has_attr2',
64 predicate => 'has_attr3',
69 package # hide from PAUSE
74 use MooseX::UndefTolerant;
76 # attrs that did not like undefs until we applied this trait
77 our @newly_tolerant_attrs = qw(attr1 attr2);
81 predicate => 'has_attr1',
86 predicate => 'has_attr2',
91 predicate => 'has_attr3',
95 package # hide from PAUSE
103 use Scalar::Util 'blessed';
104 use List::MoreUtils 'any';
106 # checks all values passing through BUILDARGS to confirm they were handled
108 # - defined fields left alone
109 # - undefined fields cleaned iff the type constraint would fail and has the
110 # UndefTolerant trait
116 my @newly_tolerant_attrs = @{blessed($obj) . '::newly_tolerant_attrs'};
117 my %original_args = $obj->args_orig;
118 my %final_args = $obj->args_final;
120 foreach my $attr (qw(attr1 attr2 attr3))
123 $TODO = 'BUILDARGS cannot be cleaned if the entire class is not undef-tolerant; see CAVEATS'
124 if $obj->meta->is_mutable and not $obj->does('MooseX::UndefTolerant::Class')
125 and exists $original_args{$attr}
126 and not defined $original_args{$attr}
127 and any { $_ eq $attr } @newly_tolerant_attrs;
130 # actual state of arg after passing through BUILDARGS
131 !exists($final_args{$attr})
133 : defined($final_args{$attr})
136 # expected state of arg after passing through BUILDARGS
138 !exists($original_args{$attr})
140 : defined($original_args{$attr})
142 : (any { $_ eq $attr } @newly_tolerant_attrs)
143 ? 'not passed' # these attrs were cleaned out
146 'constructor argument "' . $attr . '" is updated appropriately in BUILDARGS',
153 note 'Testing ', (Foo->meta->is_immutable ? 'im' : '') . 'mutable ',
154 'class with a single UndefTolerant attribute';
158 ok(!$obj->has_attr1, 'attr1 has no value before it is assigned');
159 ok(!$obj->has_attr2, 'attr2 has no value before it is assigned');
160 ok(!$obj->has_attr3, 'attr3 has no value before it is assigned');
165 $TODO = 'some immutable cases are not handled yet; see CAVEATS' if Foo->meta->is_immutable;
168 my $obj = Foo->new(attr1 => undef);
171 ok(!$obj->has_attr1, 'UT attr1 has no value when assigned undef in constructor');
173 exception { $obj = Foo->new(attr2 => undef) },
174 qr/\QAttribute (attr2) does not pass the type constraint because: Validation failed for 'Num' with value undef\E/,
175 'But assigning undef to attr2 generates a type constraint error');
177 is (exception { $obj = Foo->new(attr3 => undef) }, undef,
178 'assigning undef to attr3 is acceptable');
179 ok($obj->has_attr3, 'attr3 still has a value');
180 is($obj->attr3, undef, '...which is undef, when assigned undef in constructor');
184 'successfully tested spot-application of UT trait in '
185 . (Foo->meta->is_immutable ? 'im' : '') . 'mutable classes',
190 my $obj = Foo->new(attr1 => 1234, attr2 => 5678, attr3 => 9012);
192 is($obj->attr1, 1234, 'assigning a defined value during construction works as normal');
193 ok($obj->has_attr1, '...and the predicate returns true as normal');
195 is($obj->attr2, 5678, 'assigning a defined value during construction works as normal');
196 ok($obj->has_attr2, '...and the predicate returns true as normal');
198 is($obj->attr3, 9012, 'assigning a defined value during construction works as normal');
199 ok($obj->has_attr3, '...and the predicate returns true as normal');
203 note 'Testing class with the entire ',
204 (Bar->meta->is_immutable ? 'im' : '') . 'mutable ',
205 'class being UndefTolerant';
209 ok(!$obj->has_attr1, 'attr1 has no value before it is assigned');
210 ok(!$obj->has_attr2, 'attr2 has no value before it is assigned');
211 ok(!$obj->has_attr3, 'attr3 has no value before it is assigned');
215 my $obj = Bar->new(attr1 => undef);
217 ok(!$obj->has_attr1, 'attr1 has no value when assigned undef in constructor');
218 # note this test differs from the Foo case above
219 is (exception { $obj = Bar->new(attr2 => undef) }, undef,
220 'assigning undef to attr2 does not produce an error');
222 ok(!$obj->has_attr2, 'attr2 has no value when assigned undef in constructor');
224 is( exception { $obj = Bar->new(attr3 => undef) }, undef,
225 'assigning undef to attr3 is acceptable');
226 ok($obj->has_attr3, 'attr3 still has a value');
227 is($obj->attr3, undef, '...which is undef, when assigned undef in constructor');
232 my $obj = Bar->new(attr1 => 1234, attr2 => 5678, attr3 => 9012);
234 is($obj->attr1, 1234, 'assigning a defined value during construction works as normal');
235 ok($obj->has_attr1, '...and the predicate returns true as normal');
237 is($obj->attr2, 5678, 'assigning a defined value during construction works as normal');
238 ok($obj->has_attr2, '...and the predicate returns true as normal');
240 is($obj->attr3, 9012, 'assigning a defined value during construction works as normal');
241 ok($obj->has_attr3, '...and the predicate returns true as normal');