t/immutable/definition_context.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Test::More;
   5 use Test::Fatal;
   6
   7 {
   8     use Moose::Util::TypeConstraints;
   9     use Carp 'confess';
  10     subtype 'Death', as 'Int', where { $_ == 1 };
  11     coerce  'Death', from 'Any', via { confess };
  12 }
  13
  14 {
  15     my ($attr_foo_line, $attr_bar_line, $ctor_line);
  16     {
  17         package Foo;
  18         use Moose;
  19
  20         has foo => (
  21             is     => 'rw',
  22             isa    => 'Death',
  23             coerce => 1,
  24         );
  25         $attr_foo_line = __LINE__ - 5;
  26
  27         has bar => (
  28             accessor => 'baz',
  29             isa      => 'Death',
  30             coerce   => 1,
  31         );
  32         $attr_bar_line = __LINE__ - 5;
  33
  34         __PACKAGE__->meta->make_immutable;
  35         $ctor_line = __LINE__ - 1;
  36     }
  37
  38     like(
  39         exception { Foo->new(foo => 2) },
  40         qr/called at constructor Foo::new \(defined at $0 line $ctor_line\)/,
  41         "got definition context for the constructor"
  42     );
  43
  44     like(
  45         exception { my $f = Foo->new(foo => 1); $f->foo(2) },
  46         qr/called at accessor Foo::foo \(defined at $0 line $attr_foo_line\)/,
  47         "got definition context for the accessor"
  48     );
  49
  50     like(
  51         exception { my $f = Foo->new(foo => 1); $f->baz(2) },
  52         qr/called at accessor Foo::baz of attribute bar \(defined at $0 line $attr_bar_line\)/,
  53         "got definition context for the accessor"
  54     );
  55 }
  56
  57 {
  58     my ($dtor_line);
  59     {
  60         package Bar;
  61         use Moose;
  62
  63         # just dying here won't work, because perl's exception handling is
  64         # terrible
  65         sub DEMOLISH { try { confess } catch { warn $_ } }
  66
  67         __PACKAGE__->meta->make_immutable;
  68         $dtor_line = __LINE__ - 1;
  69     }
  70
  71     {
  72         my $warning = '';
  73         local $SIG{__WARN__} = sub { $warning .= $_[0] };
  74         { Bar->new }
  75         like(
  76             $warning,
  77             qr/called at destructor Bar::DESTROY \(defined at $0 line $dtor_line\)/,
  78             "got definition context for the destructor"
  79         );
  80     }
  81 }
  82
  83 done_testing;