t/constructor.t

   1 use Test::More;
   2 use Test::Fatal;
   3
   4 {
   5     package Foo;
   6     use Moose;
   7
   8     has 'attr1' => (
   9         traits => [ qw(MooseX::UndefTolerant::Attribute)],
  10         is => 'ro',
  11         isa => 'Num',
  12         predicate => 'has_attr1',
  13     );
  14
  15     has 'attr2' => (
  16         is => 'ro',
  17         isa => 'Num',
  18         predicate => 'has_attr2',
  19     );
  20 }
  21
  22 {
  23     package Bar;
  24     use Moose;
  25     use MooseX::UndefTolerant;
  26
  27     has 'attr1' => (
  28         is => 'ro',
  29         isa => 'Num',
  30         predicate => 'has_attr1',
  31     );
  32     has 'attr2' => (
  33         is => 'ro',
  34         isa => 'Num',
  35         predicate => 'has_attr2',
  36     );
  37 }
  38
  39 package main;
  40
  41 sub do_tests
  42 {
  43     note 'Testing class with a single UndefTolerant attribute';
  44     {
  45         my $obj = Foo->new;
  46         ok(!$obj->has_attr1, 'attr1 has no value before it is assigned');
  47         ok(!$obj->has_attr2, 'attr2 has no value before it is assigned');
  48     }
  49
  50     {
  51         my $obj = Foo->new(attr1 => undef);
  52         ok(!$obj->has_attr1, 'UT attr1 has no value when assigned undef in constructor');
  53         ok (exception { $obj = Foo->new(attr2 => undef) },
  54             'But assigning undef to attr2 generates a type constraint error');
  55     }
  56
  57     {
  58         my $obj = Foo->new(attr1 => 1234, attr2 => 5678);
  59         is($obj->attr1, 1234, 'assigning a defined value during construction works as normal');
  60         ok($obj->has_attr1, '...and the predicate returns true as normal');
  61         is($obj->attr2, 5678, 'assigning a defined value during construction works as normal');
  62         ok($obj->has_attr2, '...and the predicate returns true as normal');
  63     }
  64
  65
  66     note '';
  67     note 'Testing class with the entire class being UndefTolerant';
  68     {
  69         my $obj = Bar->new;
  70         ok(!$obj->has_attr1, 'attr1 has no value before it is assigned');
  71     }
  72
  73     {
  74         my $obj = Bar->new(attr1 => undef);
  75         ok(!$obj->has_attr1, 'attr1 has no value when assigned undef in constructor');
  76         ok (!exception { $obj = Bar->new(attr2 => undef) },
  77             'assigning undef to attr2 does not produce an error');
  78         ok(!$obj->has_attr2, 'attr2 has no value when assigned undef in constructor');
  79     }
  80
  81     {
  82         my $obj = Bar->new(attr1 => 1234);
  83         is($obj->attr1, 1234, 'assigning a defined value during construction works as normal');
  84         ok($obj->has_attr1, '...and the predicate returns true as normal');
  85     }
  86 }
  87
  88
  89 note 'Constructor behaviour: mutable classes';
  90 note '';
  91 do_tests;
  92
  93 note '';
  94 note 'Constructor behaviour: immutable classes';
  95 note '';
  96 Foo->meta->make_immutable;
  97 Bar->meta->make_immutable;
  98 TODO: {
  99     local $TODO = 'some immutable cases are not handled yet';
 100     # for now, catch errors
 101     ok(! exception { do_tests }, 'tests do not die');
 102
 103     is(Test::More->builder->current_test, 28, 'if we got here, we can declare victory!');
 104 }
 105
 106 done_testing;
 107