t/lib/ConstructorTests.pm

   1 package # hide from PAUSE
   2     ConstructorTests;
   3
   4 {
   5     package # hide from PAUSE
   6         Base;
   7     use Moose;
   8
   9     # save a before and after copy of arguments for later testing.
  10     has $_ => (
  11         isa => 'HashRef',
  12         writer => '_set_' . $_,
  13         lazy => 1,
  14         default => sub { die 'in default' },
  15         traits => ['Hash'],
  16         handles => { $_ => 'elements' },
  17     ) foreach (qw(args_orig args_final));
  18     around BUILDARGS => sub {
  19         my $orig  = shift;
  20         my $class = shift;
  21
  22         my %original_args = @_;
  23         my $args = $class->$orig(@_);
  24         return {
  25             %$args,
  26             args_orig => \%original_args,
  27         };
  28     };
  29
  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)
  33     sub BUILD
  34     {
  35         my ($self, $args) = @_;
  36         my %args = %$args;
  37         delete $args{args_orig};
  38         $self->_set_args_final(\%args);
  39     }
  40 }
  41
  42 {
  43     package # hide from PAUSE
  44         Foo;
  45     use Moose;
  46     extends 'Base';
  47
  48     # attrs that did not like undefs until we applied this trait
  49     our @newly_tolerant_attrs = qw(attr1);
  50     has 'attr1' => (
  51         traits => [ qw(MooseX::UndefTolerant::Attribute)],
  52         is => 'ro',
  53         isa => 'Num',
  54         predicate => 'has_attr1',
  55     );
  56     has 'attr2' => (
  57         is => 'ro',
  58         isa => 'Num',
  59         predicate => 'has_attr2',
  60     );
  61     has 'attr3' => (
  62         is => 'ro',
  63         isa => 'Maybe[Num]',
  64         predicate => 'has_attr3',
  65     );
  66 }
  67
  68 {
  69     package # hide from PAUSE
  70         Bar;
  71     use Moose;
  72
  73     extends 'Base';
  74     use MooseX::UndefTolerant;
  75
  76     # attrs that did not like undefs until we applied this trait
  77     our @newly_tolerant_attrs = qw(attr1 attr2);
  78     has 'attr1' => (
  79         is => 'ro',
  80         isa => 'Num',
  81         predicate => 'has_attr1',
  82     );
  83     has 'attr2' => (
  84         is => 'ro',
  85         isa => 'Num',
  86         predicate => 'has_attr2',
  87     );
  88     has 'attr3' => (
  89         is => 'ro',
  90         isa => 'Maybe[Num]',
  91         predicate => 'has_attr3',
  92     );
  93 }
  94
  95 package # hide from PAUSE
  96     ConstructorTests;
  97
  98 use strict;
  99 use warnings;
 100
 101 use Test::More;
 102 use Test::Fatal;
 103 use Scalar::Util 'blessed';
 104 use List::MoreUtils 'any';
 105
 106 # checks all values passing through BUILDARGS to confirm they were handled
 107 # appropriately:
 108 # - defined fields left alone
 109 # - undefined fields cleaned iff the type constraint would fail and has the
 110 #   UndefTolerant trait
 111 sub attrs_cleaned
 112 {
 113     my $obj = shift;
 114
 115     no strict 'refs';
 116     my @newly_tolerant_attrs = @{blessed($obj) . '::newly_tolerant_attrs'};
 117     my %original_args = $obj->args_orig;
 118     my %final_args = $obj->args_final;
 119
 120     foreach my $attr (qw(attr1 attr2 attr3))
 121     {
 122         local $TODO;
 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;
 128
 129         is(
 130             # actual state of arg after passing through BUILDARGS
 131             !exists($final_args{$attr})
 132                 ? 'not passed'
 133                 : defined($final_args{$attr})
 134                 ? 'defined'
 135                 : 'undefined',
 136             # expected state of arg after passing through BUILDARGS
 137             do {
 138                 !exists($original_args{$attr})
 139                     ? 'not passed'
 140                     : defined($original_args{$attr})
 141                     ? 'defined'
 142                     : (any { $_ eq $attr } @newly_tolerant_attrs)
 143                     ? 'not passed'    # these attrs were cleaned out
 144                     : 'undefined';
 145             },
 146             'constructor argument "' . $attr . '" is updated appropriately in BUILDARGS',
 147         );
 148     }
 149 }
 150
 151 sub do_tests
 152 {
 153     note 'Testing ', (Foo->meta->is_immutable ? 'im' : '') . 'mutable ',
 154         'class with a single UndefTolerant attribute';
 155     {
 156         my $obj = Foo->new;
 157         attrs_cleaned($obj);
 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');
 161     }
 162
 163     TODO: {
 164         local $TODO;
 165         $TODO = 'some immutable cases are not handled yet; see CAVEATS' if Foo->meta->is_immutable;
 166         is(
 167             exception {
 168                 my $obj = Foo->new(attr1 => undef);
 169                 attrs_cleaned($obj);
 170
 171                 ok(!$obj->has_attr1, 'UT attr1 has no value when assigned undef in constructor');
 172                 like(
 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');
 176
 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');
 181                 attrs_cleaned($obj);
 182             },
 183             undef,
 184             'successfully tested spot-application of UT trait in '
 185                 . (Foo->meta->is_immutable ? 'im' : '') . 'mutable classes',
 186         );
 187     }
 188
 189     {
 190         my $obj = Foo->new(attr1 => 1234, attr2 => 5678, attr3 => 9012);
 191         attrs_cleaned($obj);
 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');
 194
 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');
 197
 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');
 200     }
 201
 202     note '';
 203     note 'Testing class with the entire ',
 204         (Bar->meta->is_immutable ? 'im' : '') . 'mutable ',
 205         'class being UndefTolerant';
 206     {
 207         my $obj = Bar->new;
 208         attrs_cleaned($obj);
 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');
 212     }
 213
 214     {
 215         my $obj = Bar->new(attr1 => undef);
 216         attrs_cleaned($obj);
 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');
 221         attrs_cleaned($obj);
 222         ok(!$obj->has_attr2, 'attr2 has no value when assigned undef in constructor');
 223
 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');
 228         attrs_cleaned($obj);
 229     }
 230
 231     {
 232         my $obj = Bar->new(attr1 => 1234, attr2 => 5678, attr3 => 9012);
 233         attrs_cleaned($obj);
 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');
 236
 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');
 239
 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');
 242     }
 243 }
 244
 245 1;