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