This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
syswrite() wasn't reporting a warning when writing to a filehandle
[perl5.git] / lib / Module / Build / t / extend.t
CommitLineData
bb4e9162
YST
1#!/usr/bin/perl -w
2
3use strict;
4use lib $ENV{PERL_CORE} ? '../lib/Module/Build/t/lib' : 't/lib';
dc8021d3 5use MBTest tests => 64;
bb4e9162
YST
6
7use Cwd ();
8my $cwd = Cwd::cwd;
9my $tmp = File::Spec->catdir( $cwd, 't', '_tmp' );
10
11use DistGen;
12my $dist = DistGen->new( dir => $tmp );
13$dist->regen;
14
15chdir( $dist->dirname ) or die "Can't chdir to '@{[$dist->dirname]}': $!";
16
17#########################
18
19use Module::Build;
20ok 1;
21
22# Here we make sure actions are only called once per dispatch()
23$::x = 0;
24my $mb = Module::Build->subclass
25 (
26 code => "sub ACTION_loop { die 'recursed' if \$::x++; shift->depends_on('loop'); }"
27 )->new( module_name => $dist->name );
28ok $mb;
29
30$mb->dispatch('loop');
31ok $::x;
32
33$mb->dispatch('realclean');
34
35# Make sure the subclass can be subclassed
36my $build2class = ref($mb)->subclass
37 (
38 code => "sub ACTION_loop2 {}",
39 class => 'MBB',
40 );
41can_ok( $build2class, 'ACTION_loop' );
42can_ok( $build2class, 'ACTION_loop2' );
43
44
45{ # Make sure globbing works in filenames
46 $dist->add_file( 'script', <<'---' );
47#!perl -w
48print "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
SP
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
f4892442 230 SKIP:{
dc8021d3 231
f4892442 232 skip "No available STDIN", 7 unless -t STDIN;
dc8021d3 233
f4892442 234 $ENV{PERL_MM_USE_DEFAULT} = 1;
dc8021d3 235
f4892442
SP
236 eval{ $mb->y_n("# Is this a question?") };
237 like $@, qr/ERROR:/, 'Do not allow default-less y_n() for unattended builds';
dc8021d3 238
f4892442
SP
239 eval{ $ans = $mb->prompt('# Is this a question?') };
240 like $@, qr/ERROR:/, 'Do not allow default-less prompt() for unattended builds';
dc8021d3 241
f4892442 242 $ENV{PERL_MM_USE_DEFAULT} = 0;
dc8021d3 243
f4892442
SP
244 $ans = $mb->prompt('# Is this a question?');
245 print "\n"; # fake <enter> after input
246 is $ans, 'y', "prompt() doesn't require default for interactive builds";
dc8021d3 247
f4892442
SP
248 $ans = $mb->y_n('# Say yes');
249 print "\n"; # fake <enter> after input
250 ok $ans, "y_n() doesn't require default for interactive build";
dc8021d3
SP
251
252
f4892442
SP
253 # Test Defaults
254 *{Module::Build::_readline} = sub { '' };
dc8021d3 255
f4892442
SP
256 $ans = $mb->prompt("# Is this a question");
257 is $ans, '', "default for prompt() without a default is ''";
dc8021d3 258
f4892442
SP
259 $ans = $mb->prompt("# Is this a question", 'y');
260 is $ans, 'y', " prompt() with a default";
dc8021d3 261
f4892442
SP
262 $ans = $mb->y_n("# Is this a question", 'y');
263 ok $ans, " y_n() with a default";
264 }
dc8021d3 265}
bb4e9162
YST
266
267# cleanup
268chdir( $cwd ) or die "Can''t chdir to '$cwd': $!";
269$dist->remove;
270
271use File::Path;
272rmtree( $tmp );