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