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