Commit | Line | Data |
bb4e9162 |
1 | #!/usr/bin/perl -w |
2 | |
3 | use strict; |
4 | use lib $ENV{PERL_CORE} ? '../lib/Module/Build/t/lib' : 't/lib'; |
7253302f |
5 | use MBTest tests => 65; |
bb4e9162 |
6 | |
7 | use Cwd (); |
8 | my $cwd = Cwd::cwd; |
9 | my $tmp = File::Spec->catdir( $cwd, 't', '_tmp' ); |
10 | |
11 | use DistGen; |
12 | my $dist = DistGen->new( dir => $tmp ); |
13 | $dist->regen; |
14 | |
15 | chdir( $dist->dirname ) or die "Can't chdir to '@{[$dist->dirname]}': $!"; |
16 | |
17 | ######################### |
18 | |
19 | use Module::Build; |
20 | ok 1; |
21 | |
22 | # Here we make sure actions are only called once per dispatch() |
23 | $::x = 0; |
24 | my $mb = Module::Build->subclass |
25 | ( |
26 | code => "sub ACTION_loop { die 'recursed' if \$::x++; shift->depends_on('loop'); }" |
27 | )->new( module_name => $dist->name ); |
28 | ok $mb; |
29 | |
30 | $mb->dispatch('loop'); |
31 | ok $::x; |
32 | |
33 | $mb->dispatch('realclean'); |
34 | |
35 | # Make sure the subclass can be subclassed |
36 | my $build2class = ref($mb)->subclass |
37 | ( |
38 | code => "sub ACTION_loop2 {}", |
39 | class => 'MBB', |
40 | ); |
41 | can_ok( $build2class, 'ACTION_loop' ); |
42 | can_ok( $build2class, 'ACTION_loop2' ); |
43 | |
44 | |
45 | { # Make sure globbing works in filenames |
46 | $dist->add_file( 'script', <<'---' ); |
47 | #!perl -w |
48 | print "Hello, World!\n"; |
49 | --- |
50 | $dist->regen; |
51 | |
52 | $mb->test_files('*t*'); |
53 | my $files = $mb->test_files; |
54 | ok grep {$_ eq 'script'} @$files; |
55 | ok grep {$_ eq File::Spec->catfile('t', 'basic.t')} @$files; |
56 | ok !grep {$_ eq 'Build.PL' } @$files; |
57 | |
58 | # Make sure order is preserved |
59 | $mb->test_files('foo', 'bar'); |
60 | $files = $mb->test_files; |
61 | is @$files, 2; |
62 | is $files->[0], 'foo'; |
63 | is $files->[1], 'bar'; |
64 | |
65 | $dist->remove_file( 'script' ); |
66 | $dist->regen( clean => 1 ); |
67 | } |
68 | |
69 | |
70 | { |
71 | # Make sure we can add new kinds of stuff to the build sequence |
72 | |
73 | $dist->add_file( 'test.foo', "content\n" ); |
74 | $dist->regen; |
75 | |
76 | my $mb = Module::Build->new( module_name => $dist->name, |
77 | foo_files => {'test.foo', 'lib/test.foo'} ); |
78 | ok $mb; |
79 | |
80 | $mb->add_build_element('foo'); |
81 | $mb->add_build_element('foo'); |
82 | is_deeply $mb->build_elements, [qw(PL support pm xs pod script foo)], |
83 | 'The foo element should be in build_elements only once'; |
84 | |
85 | $mb->dispatch('build'); |
86 | ok -e File::Spec->catfile($mb->blib, 'lib', 'test.foo'); |
87 | |
88 | $mb->dispatch('realclean'); |
89 | |
90 | # revert distribution to a pristine state |
91 | $dist->remove_file( 'test.foo' ); |
92 | $dist->regen( clean => 1 ); |
93 | } |
94 | |
95 | |
96 | { |
97 | package MBSub; |
98 | use Test::More; |
99 | use vars qw($VERSION @ISA); |
100 | @ISA = qw(Module::Build); |
101 | $VERSION = 0.01; |
102 | |
103 | # Add a new property. |
104 | ok(__PACKAGE__->add_property('foo')); |
105 | # Add a new property with a default value. |
106 | ok(__PACKAGE__->add_property('bar', 'hey')); |
107 | # Add a hash property. |
108 | ok(__PACKAGE__->add_property('hash', {})); |
109 | |
110 | |
111 | # Catch an exception adding an existing property. |
112 | eval { __PACKAGE__->add_property('module_name')}; |
113 | like "$@", qr/already exists/; |
114 | } |
115 | |
116 | { |
117 | package MBSub2; |
118 | use Test::More; |
119 | use vars qw($VERSION @ISA); |
120 | @ISA = qw(Module::Build); |
121 | $VERSION = 0.01; |
122 | |
123 | # Add a new property with a different default value than MBSub has. |
124 | ok(__PACKAGE__->add_property('bar', 'yow')); |
125 | } |
126 | |
127 | |
128 | { |
129 | ok my $mb = MBSub->new( module_name => $dist->name ); |
130 | isa_ok $mb, 'Module::Build'; |
131 | isa_ok $mb, 'MBSub'; |
132 | ok $mb->valid_property('foo'); |
133 | can_ok $mb, 'module_name'; |
134 | |
135 | # Check foo property. |
136 | can_ok $mb, 'foo'; |
137 | ok ! $mb->foo; |
138 | ok $mb->foo(1); |
139 | ok $mb->foo; |
140 | |
141 | # Check bar property. |
142 | can_ok $mb, 'bar'; |
143 | is $mb->bar, 'hey'; |
144 | ok $mb->bar('you'); |
145 | is $mb->bar, 'you'; |
146 | |
147 | # Check hash property. |
148 | ok $mb = MBSub->new( |
149 | module_name => $dist->name, |
150 | hash => { foo => 'bar', bin => 'foo'} |
151 | ); |
152 | |
153 | can_ok $mb, 'hash'; |
154 | isa_ok $mb->hash, 'HASH'; |
155 | is $mb->hash->{foo}, 'bar'; |
156 | is $mb->hash->{bin}, 'foo'; |
157 | |
158 | # Check hash property passed via the command-line. |
159 | { |
160 | local @ARGV = ( |
161 | '--hash', 'foo=bar', |
162 | '--hash', 'bin=foo', |
163 | ); |
164 | ok $mb = MBSub->new( module_name => $dist->name ); |
165 | } |
166 | |
167 | can_ok $mb, 'hash'; |
168 | isa_ok $mb->hash, 'HASH'; |
169 | is $mb->hash->{foo}, 'bar'; |
170 | is $mb->hash->{bin}, 'foo'; |
171 | |
172 | # Make sure that a different subclass with the same named property has a |
173 | # different default. |
174 | ok $mb = MBSub2->new( module_name => $dist->name ); |
175 | isa_ok $mb, 'Module::Build'; |
176 | isa_ok $mb, 'MBSub2'; |
177 | ok $mb->valid_property('bar'); |
178 | can_ok $mb, 'bar'; |
179 | is $mb->bar, 'yow'; |
180 | } |
181 | |
182 | { |
183 | # Test the meta_add and meta_merge stuff |
184 | ok my $mb = Module::Build->new( |
185 | module_name => $dist->name, |
186 | license => 'perl', |
187 | meta_add => {foo => 'bar'}, |
188 | conflicts => {'Foo::Barxx' => 0}, |
189 | ); |
190 | my %data; |
191 | $mb->prepare_metadata( \%data ); |
192 | is $data{foo}, 'bar'; |
193 | |
194 | $mb->meta_merge(foo => 'baz'); |
195 | $mb->prepare_metadata( \%data ); |
196 | is $data{foo}, 'baz'; |
197 | |
198 | $mb->meta_merge(conflicts => {'Foo::Fooxx' => 0}); |
199 | $mb->prepare_metadata( \%data ); |
200 | is_deeply $data{conflicts}, {'Foo::Barxx' => 0, 'Foo::Fooxx' => 0}; |
201 | |
202 | $mb->meta_add(conflicts => {'Foo::Bazxx' => 0}); |
203 | $mb->prepare_metadata( \%data ); |
204 | is_deeply $data{conflicts}, {'Foo::Bazxx' => 0, 'Foo::Fooxx' => 0}; |
205 | } |
206 | |
dc8021d3 |
207 | { |
208 | # Test interactive prompting |
209 | |
210 | my $ans; |
211 | local $ENV{PERL_MM_USE_DEFAULT}; |
212 | |
213 | local $^W = 0; |
214 | local *{Module::Build::_readline} = sub { 'y' }; |
215 | |
216 | ok my $mb = Module::Build->new( |
217 | module_name => $dist->name, |
218 | license => 'perl', |
219 | ); |
220 | |
221 | eval{ $mb->prompt() }; |
222 | like $@, qr/called without a prompt/, 'prompt() requires a prompt'; |
223 | |
224 | eval{ $mb->y_n() }; |
225 | like $@, qr/called without a prompt/, 'y_n() requires a prompt'; |
226 | |
227 | eval{ $mb->y_n('Prompt?', 'invalid default') }; |
228 | like $@, qr/Invalid default/, "y_n() requires a default of 'y' or 'n'"; |
229 | |
230 | |
77e96e88 |
231 | $ENV{PERL_MM_USE_DEFAULT} = 1; |
dc8021d3 |
232 | |
77e96e88 |
233 | eval{ $mb->y_n('Is this a question?') }; |
7253302f |
234 | print "\n"; # fake <enter> because the prompt prints before the checks |
77e96e88 |
235 | like $@, qr/ERROR:/, |
236 | 'Do not allow default-less y_n() for unattended builds'; |
dc8021d3 |
237 | |
77e96e88 |
238 | eval{ $ans = $mb->prompt('Is this a question?') }; |
7253302f |
239 | print "\n"; # fake <enter> because the prompt prints before the checks |
77e96e88 |
240 | like $@, qr/ERROR:/, |
241 | 'Do not allow default-less prompt() for unattended builds'; |
dc8021d3 |
242 | |
77e96e88 |
243 | |
244 | # When running Test::Smoke under a cron job, STDIN will be closed which |
245 | # will fool our _is_interactive() method causing various failures. |
246 | { |
247 | local *{Module::Build::_is_interactive} = sub { 1 }; |
dc8021d3 |
248 | |
f4892442 |
249 | $ENV{PERL_MM_USE_DEFAULT} = 0; |
dc8021d3 |
250 | |
77e96e88 |
251 | $ans = $mb->prompt('Is this a question?'); |
f4892442 |
252 | print "\n"; # fake <enter> after input |
253 | is $ans, 'y', "prompt() doesn't require default for interactive builds"; |
dc8021d3 |
254 | |
77e96e88 |
255 | $ans = $mb->y_n('Say yes'); |
f4892442 |
256 | print "\n"; # fake <enter> after input |
257 | ok $ans, "y_n() doesn't require default for interactive build"; |
dc8021d3 |
258 | |
259 | |
f4892442 |
260 | # Test Defaults |
261 | *{Module::Build::_readline} = sub { '' }; |
dc8021d3 |
262 | |
77e96e88 |
263 | $ans = $mb->prompt("Is this a question"); |
f4892442 |
264 | is $ans, '', "default for prompt() without a default is ''"; |
dc8021d3 |
265 | |
77e96e88 |
266 | $ans = $mb->prompt("Is this a question", 'y'); |
f4892442 |
267 | is $ans, 'y', " prompt() with a default"; |
dc8021d3 |
268 | |
77e96e88 |
269 | $ans = $mb->y_n("Is this a question", 'y'); |
f4892442 |
270 | ok $ans, " y_n() with a default"; |
7253302f |
271 | |
272 | my @ans = $mb->prompt("Is this a question", undef); |
273 | is_deeply([@ans], [undef], " prompt() with undef() default"); |
f4892442 |
274 | } |
77e96e88 |
275 | |
dc8021d3 |
276 | } |
bb4e9162 |
277 | |
278 | # cleanup |
279 | chdir( $cwd ) or die "Can''t chdir to '$cwd': $!"; |
280 | $dist->remove; |
281 | |
282 | use File::Path; |
283 | rmtree( $tmp ); |