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