Commit | Line | Data |
0f1a71fc |
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; |