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