Commit | Line | Data |
c2cc003f |
1 | |
2 | use strictures 1; |
3 | use Test::More; |
4 | use Test::Fatal; |
5 | use FindBin; |
6 | |
7 | |
8 | my $FilePath = sub { die "does not pass the type constraint" if $_[0] eq '/' }; |
9 | |
10 | { |
11 | package Baz; |
12 | use Moo; |
13 | |
14 | has 'path' => ( |
15 | is => 'ro', |
16 | isa => $FilePath, |
17 | required => 1, |
18 | ); |
19 | |
20 | sub BUILD { |
21 | my ( $self, $params ) = @_; |
22 | die $params->{path} . " does not exist" |
23 | unless -e $params->{path}; |
24 | } |
25 | |
26 | # Defining this causes the FIRST call to Baz->new w/o param to fail, |
27 | # if no call to ANY Moo::Object->new was done before. |
28 | sub DEMOLISH { |
29 | my ( $self ) = @_; |
30 | } |
31 | } |
32 | |
33 | { |
34 | package Qee; |
35 | use Moo; |
36 | |
37 | has 'path' => ( |
38 | is => 'ro', |
39 | isa => $FilePath, |
40 | required => 1, |
41 | ); |
42 | |
43 | sub BUILD { |
44 | my ( $self, $params ) = @_; |
45 | die $params->{path} . " does not exist" |
46 | unless -e $params->{path}; |
47 | } |
48 | |
49 | # Defining this causes the FIRST call to Qee->new w/o param to fail... |
50 | # if no call to ANY Moo::Object->new was done before. |
51 | sub DEMOLISH { |
52 | my ( $self ) = @_; |
53 | } |
54 | } |
55 | |
56 | { |
57 | package Foo; |
58 | use Moo; |
59 | |
60 | has 'path' => ( |
61 | is => 'ro', |
62 | isa => $FilePath, |
63 | required => 1, |
64 | ); |
65 | |
66 | sub BUILD { |
67 | my ( $self, $params ) = @_; |
68 | die $params->{path} . " does not exist" |
69 | unless -e $params->{path}; |
70 | } |
71 | |
72 | # Having no DEMOLISH, everything works as expected... |
73 | } |
74 | |
75 | check_em ( 'Baz' ); # 'Baz plain' will fail, aka NO error |
76 | check_em ( 'Qee' ); # ok |
77 | check_em ( 'Foo' ); # ok |
78 | |
79 | check_em ( 'Qee' ); # 'Qee plain' will fail, aka NO error |
80 | check_em ( 'Baz' ); # ok |
81 | check_em ( 'Foo' ); # ok |
82 | |
83 | check_em ( 'Foo' ); # ok |
84 | check_em ( 'Baz' ); # ok ! |
85 | check_em ( 'Qee' ); # ok |
86 | |
87 | |
88 | sub check_em { |
89 | my ( $pkg ) = @_; |
90 | my ( %param, $obj ); |
91 | |
92 | # Uncomment to see, that it is really any first call. |
93 | # Subsequents calls will not fail, aka giving the correct error. |
94 | { |
95 | local $@; |
96 | my $obj = eval { $pkg->new; }; |
97 | ::like( $@, qr/Missing required argument/, "... $pkg plain" ); |
98 | ::is( $obj, undef, "... the object is undef" ); |
99 | } |
100 | { |
101 | local $@; |
102 | my $obj = eval { $pkg->new(); }; |
103 | ::like( $@, qr/Missing required argument/, "... $pkg empty" ); |
104 | ::is( $obj, undef, "... the object is undef" ); |
105 | } |
106 | { |
107 | local $@; |
108 | my $obj = eval { $pkg->new ( notanattr => 1 ); }; |
109 | ::like( $@, qr/Missing required argument/, "... $pkg undef" ); |
110 | ::is( $obj, undef, "... the object is undef" ); |
111 | } |
112 | |
113 | { |
114 | local $@; |
115 | my $obj = eval { $pkg->new ( %param ); }; |
116 | ::like( $@, qr/Missing required argument/, "... $pkg undef param" ); |
117 | ::is( $obj, undef, "... the object is undef" ); |
118 | } |
119 | { |
120 | local $@; |
121 | my $obj = eval { $pkg->new ( path => '/' ); }; |
122 | ::like( $@, qr/does not pass the type constraint/, "... $pkg root path forbidden" ); |
123 | ::is( $obj, undef, "... the object is undef" ); |
124 | } |
125 | { |
126 | local $@; |
127 | my $obj = eval { $pkg->new ( path => '/this_path/does/not_exist' ); }; |
128 | ::like( $@, qr/does not exist/, "... $pkg non existing path" ); |
129 | ::is( $obj, undef, "... the object is undef" ); |
130 | } |
131 | { |
132 | local $@; |
133 | my $obj = eval { $pkg->new ( path => $FindBin::Bin ); }; |
134 | ::is( $@, '', "... $pkg no error" ); |
135 | ::isa_ok( $obj, $pkg ); |
136 | ::isa_ok( $obj, 'Moo::Object' ); |
137 | ::is( $obj->path, $FindBin::Bin, "... $pkg got the right value" ); |
138 | } |
139 | } |
140 | |
141 | done_testing; |