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