t/accessor-isa.t

   1 use strictures 1;
   2 use Test::More;
   3 use Test::Fatal;
   4
   5 sub run_for {
   6   my $class = shift;
   7
   8   my $obj = $class->new(less_than_three => 1);
   9
  10   is($obj->less_than_three, 1, "initial value set (${class})");
  11
  12   like(
  13     exception { $obj->less_than_three(4) },
  14     qr/isa check for "less_than_three" failed: 4 is not less than three/,
  15     "exception thrown on bad set (${class})"
  16   );
  17
  18   is($obj->less_than_three, 1, "initial value remains after bad set (${class})");
  19
  20   my $ret;
  21
  22   is(
  23     exception { $ret = $obj->less_than_three(2) },
  24     undef, "no exception on correct set (${class})"
  25   );
  26
  27   is($ret, 2, "correct setter return (${class})");
  28   is($obj->less_than_three, 2, "correct getter return (${class})");
  29
  30   is(exception { $class->new }, undef, "no exception with no value (${class})");
  31   like(
  32     exception { $class->new(less_than_three => 12) },
  33     qr/isa check for "less_than_three" failed: 12 is not less than three/,
  34     "exception thrown on bad constructor arg (${class})"
  35   );
  36 }
  37
  38 {
  39   package Foo;
  40
  41   use Moo;
  42
  43   has less_than_three => (
  44     is => 'rw',
  45     isa => sub { die "$_[0] is not less than three" unless $_[0] < 3 }
  46   );
  47 }
  48
  49 run_for 'Foo';
  50
  51 {
  52   package Bar;
  53
  54   use Sub::Quote;
  55   use Moo;
  56
  57   has less_than_three => (
  58     is => 'rw',
  59     isa => quote_sub q{
  60       my ($x) = @_;
  61       die "$x is not less than three" unless $x < 3
  62     }
  63   );
  64 }
  65
  66 run_for 'Bar';
  67
  68 {
  69   package Baz;
  70
  71   use Sub::Quote;
  72   use Moo;
  73
  74   has less_than_three => (
  75     is => 'rw',
  76     isa => quote_sub(
  77       q{
  78         my ($value) = @_;
  79         die "$value is not less than ${word}" unless $value < $limit
  80       },
  81       { '$limit' => \3, '$word' => \'three' }
  82     )
  83   );
  84 }
  85
  86 run_for 'Baz';
  87
  88 my $lt3;
  89
  90 {
  91   package LazyFoo;
  92
  93   use Sub::Quote;
  94   use Moo;
  95
  96   has less_than_three => (
  97     is => 'lazy',
  98     isa => quote_sub(q{ die "$_[0] is not less than three" unless $_[0] < 3 })
  99   );
 100
 101   sub _build_less_than_three { $lt3 }
 102 }
 103
 104 $lt3 = 4;
 105
 106 my $lazyfoo = LazyFoo->new;
 107 like(
 108   exception { $lazyfoo->less_than_three },
 109   qr/isa check for "less_than_three" failed: 4 is not less than three/,
 110   "exception thrown on bad builder return value (LazyFoo)"
 111 );
 112
 113 $lt3 = 2;
 114
 115 is(
 116   exception { $lazyfoo->less_than_three },
 117   undef,
 118   'Corrected builder value on existing object returned ok'
 119 );
 120
 121 is(LazyFoo->new->less_than_three, 2, 'Correct builder value returned ok');
 122
 123 {
 124   package Fizz;
 125
 126   use Moo;
 127
 128   has attr1 => (
 129     is => 'ro',
 130     isa => sub {
 131       no warnings 'once';
 132       my $attr = $Method::Generate::Accessor::CurrentAttribute;
 133       die bless [@$attr{'name', 'init_arg', 'step'}], 'MyException';
 134     },
 135     init_arg => 'attr_1',
 136   );
 137 }
 138
 139 my $e = exception { Fizz->new(attr_1 => 5) };
 140 is(
 141   ref($e),
 142   'MyException',
 143   'Exception objects passed though correctly',
 144 );
 145
 146 is($e->[0], 'attr1', 'attribute name available in isa check');
 147 is($e->[1], 'attr_1', 'attribute init_arg available in isa check');
 148 is($e->[2], 'isa check', 'step available in isa check');
 149
 150 {
 151   my $called;
 152   local $SIG{__DIE__} = sub { $called++; die $_[0] };
 153   my $e = exception { Fizz->new(attr_1 => 5) };
 154   is($called, 1, '__DIE__ handler called if set')
 155 }
 156
 157 {
 158   package ClassWithDeadlyIsa;
 159   use Moo;
 160   has foo => (is => 'ro', isa => sub { die "nope" });
 161
 162   package ClassUsingDeadlyIsa;
 163   use Moo;
 164   has bar => (is => 'ro', coerce => sub { ClassWithDeadlyIsa->new(foo => $_[0]) });
 165 }
 166
 167 like exception { ClassUsingDeadlyIsa->new(bar => 1) },
 168   qr/isa check for "foo" failed: nope/,
 169   'isa check within isa check produces correct exception';
 170
 171 done_testing;