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