[perl5.git] / lib / Module / Build / t / extend.t

#!/usr/bin/perl -w

use strict;
use lib $ENV{PERL_CORE} ? '../lib/Module/Build/t/lib' : 't/lib';
use MBTest tests => 64;

use Cwd ();
my $cwd = Cwd::cwd;
my $tmp = File::Spec->catdir( $cwd, 't', '_tmp' );

use DistGen;
my $dist = DistGen->new( dir => $tmp );
$dist->regen;

chdir( $dist->dirname ) or die "Can't chdir to '@{[$dist->dirname]}': $!";

#########################

use Module::Build;
ok 1;

# Here we make sure actions are only called once per dispatch()
$::x = 0;
my $mb = Module::Build->subclass
  (
   code => "sub ACTION_loop { die 'recursed' if \$::x++; shift->depends_on('loop'); }"
  )->new( module_name => $dist->name );
ok $mb;

$mb->dispatch('loop');
ok $::x;

$mb->dispatch('realclean');

# Make sure the subclass can be subclassed
my $build2class = ref($mb)->subclass
  (
   code => "sub ACTION_loop2 {}",
   class => 'MBB',
  );
can_ok( $build2class, 'ACTION_loop' );
can_ok( $build2class, 'ACTION_loop2' );


{ # Make sure globbing works in filenames
  $dist->add_file( 'script', <<'---' );
#!perl -w
print "Hello, World!\n";
---
  $dist->regen;

  $mb->test_files('*t*');
  my $files = $mb->test_files;
  ok  grep {$_ eq 'script'}    @$files;
  ok  grep {$_ eq File::Spec->catfile('t', 'basic.t')} @$files;
  ok !grep {$_ eq 'Build.PL' } @$files;

  # Make sure order is preserved
  $mb->test_files('foo', 'bar');
  $files = $mb->test_files;
  is @$files, 2;
  is $files->[0], 'foo';
  is $files->[1], 'bar';

  $dist->remove_file( 'script' );
  $dist->regen( clean => 1 );
}


{
  # Make sure we can add new kinds of stuff to the build sequence

  $dist->add_file( 'test.foo', "content\n" );
  $dist->regen;

  my $mb = Module::Build->new( module_name => $dist->name,
			       foo_files => {'test.foo', 'lib/test.foo'} );
  ok $mb;

  $mb->add_build_element('foo');
  $mb->add_build_element('foo');
  is_deeply $mb->build_elements, [qw(PL support pm xs pod script foo)],
      'The foo element should be in build_elements only once';

  $mb->dispatch('build');
  ok -e File::Spec->catfile($mb->blib, 'lib', 'test.foo');

  $mb->dispatch('realclean');

  # revert distribution to a pristine state
  $dist->remove_file( 'test.foo' );
  $dist->regen( clean => 1 );
}


{
  package MBSub;
  use Test::More;
  use vars qw($VERSION @ISA);
  @ISA = qw(Module::Build);
  $VERSION = 0.01;
  
  # Add a new property.
  ok(__PACKAGE__->add_property('foo'));
  # Add a new property with a default value.
  ok(__PACKAGE__->add_property('bar', 'hey'));
  # Add a hash property.
  ok(__PACKAGE__->add_property('hash', {}));
  
  
  # Catch an exception adding an existing property.
  eval { __PACKAGE__->add_property('module_name')};
  like "$@", qr/already exists/;
}

{
  package MBSub2;
  use Test::More;
  use vars qw($VERSION @ISA);
  @ISA = qw(Module::Build);
  $VERSION = 0.01;
  
  # Add a new property with a different default value than MBSub has.
  ok(__PACKAGE__->add_property('bar', 'yow'));
}


{
  ok my $mb = MBSub->new( module_name => $dist->name );
  isa_ok $mb, 'Module::Build';
  isa_ok $mb, 'MBSub';
  ok $mb->valid_property('foo');
  can_ok $mb, 'module_name';
  
  # Check foo property.
  can_ok $mb, 'foo';
  ok ! $mb->foo;
  ok $mb->foo(1);
  ok $mb->foo;
  
  # Check bar property.
  can_ok $mb, 'bar';
  is $mb->bar, 'hey';
  ok $mb->bar('you');
  is $mb->bar, 'you';
  
  # Check hash property.
  ok $mb = MBSub->new(
		       module_name => $dist->name,
		       hash        => { foo => 'bar', bin => 'foo'}
		     );
  
  can_ok $mb, 'hash';
  isa_ok $mb->hash, 'HASH';
  is $mb->hash->{foo}, 'bar';
  is $mb->hash->{bin}, 'foo';
  
  # Check hash property passed via the command-line.
  {
    local @ARGV = (
		   '--hash', 'foo=bar',
		   '--hash', 'bin=foo',
		  );
    ok $mb = MBSub->new( module_name => $dist->name );
  }

  can_ok $mb, 'hash';
  isa_ok $mb->hash, 'HASH';
  is $mb->hash->{foo}, 'bar';
  is $mb->hash->{bin}, 'foo';
  
  # Make sure that a different subclass with the same named property has a
  # different default.
  ok $mb = MBSub2->new( module_name => $dist->name );
  isa_ok $mb, 'Module::Build';
  isa_ok $mb, 'MBSub2';
  ok $mb->valid_property('bar');
  can_ok $mb, 'bar';
  is $mb->bar, 'yow';
}

{
  # Test the meta_add and meta_merge stuff
  ok my $mb = Module::Build->new(
				  module_name => $dist->name,
				  license => 'perl',
				  meta_add => {foo => 'bar'},
				  conflicts => {'Foo::Barxx' => 0},
			        );
  my %data;
  $mb->prepare_metadata( \%data );
  is $data{foo}, 'bar';

  $mb->meta_merge(foo => 'baz');
  $mb->prepare_metadata( \%data );
  is $data{foo}, 'baz';

  $mb->meta_merge(conflicts => {'Foo::Fooxx' => 0});
  $mb->prepare_metadata( \%data );
  is_deeply $data{conflicts}, {'Foo::Barxx' => 0, 'Foo::Fooxx' => 0};

  $mb->meta_add(conflicts => {'Foo::Bazxx' => 0});
  $mb->prepare_metadata( \%data );
  is_deeply $data{conflicts}, {'Foo::Bazxx' => 0, 'Foo::Fooxx' => 0};
}

{
  # Test interactive prompting

  my $ans;
  local $ENV{PERL_MM_USE_DEFAULT};

  local $^W = 0;
  local *{Module::Build::_readline} = sub { 'y' };

  ok my $mb = Module::Build->new(
				  module_name => $dist->name,
				  license => 'perl',
			        );

  eval{ $mb->prompt() };
  like $@, qr/called without a prompt/, 'prompt() requires a prompt';

  eval{ $mb->y_n() };
  like $@, qr/called without a prompt/, 'y_n() requires a prompt';

  eval{ $mb->y_n('Prompt?', 'invalid default') };
  like $@, qr/Invalid default/, "y_n() requires a default of 'y' or 'n'";


  $ENV{PERL_MM_USE_DEFAULT} = 1;

  eval{ $mb->y_n('Is this a question?') };
  like $@, qr/ERROR:/,
       'Do not allow default-less y_n() for unattended builds';

  eval{ $ans = $mb->prompt('Is this a question?') };
  like $@, qr/ERROR:/,
       'Do not allow default-less prompt() for unattended builds';


  # When running Test::Smoke under a cron job, STDIN will be closed which
  # will fool our _is_interactive() method causing various failures.
  {
    local *{Module::Build::_is_interactive} = sub { 1 };

    $ENV{PERL_MM_USE_DEFAULT} = 0;

    $ans = $mb->prompt('Is this a question?');
    print "\n"; # fake <enter> after input
    is $ans, 'y', "prompt() doesn't require default for interactive builds";

    $ans = $mb->y_n('Say yes');
    print "\n"; # fake <enter> after input
    ok $ans, "y_n() doesn't require default for interactive build";


    # Test Defaults
    *{Module::Build::_readline} = sub { '' };

    $ans = $mb->prompt("Is this a question");
    is $ans, '', "default for prompt() without a default is ''";

    $ans = $mb->prompt("Is this a question", 'y');
    is $ans, 'y', "  prompt() with a default";

    $ans = $mb->y_n("Is this a question", 'y');
    ok $ans, "  y_n() with a default";
  }

}

# cleanup
chdir( $cwd ) or die "Can''t chdir to '$cwd': $!";
$dist->remove;

use File::Path;
rmtree( $tmp );
Commit	Line	Data
bb4e9162 YST	1	#!/usr/bin/perl -w
	2
	3	use strict;
	4	use lib $ENV{PERL_CORE} ? '../lib/Module/Build/t/lib' : 't/lib';
dc8021d3	5	use MBTest tests => 64;
bb4e9162 YST	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 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
	230
77e96e88	231	$ENV{PERL_MM_USE_DEFAULT} = 1;
dc8021d3	232
77e96e88 RGS	233	eval{ $mb->y_n('Is this a question?') };
	234	like $@, qr/ERROR:/,
	235	'Do not allow default-less y_n() for unattended builds';
dc8021d3	236
77e96e88 RGS	237	eval{ $ans = $mb->prompt('Is this a question?') };
	238	like $@, qr/ERROR:/,
	239	'Do not allow default-less prompt() for unattended builds';
dc8021d3	240
77e96e88 RGS	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 SP	250	print "\n"; # fake <enter> after input
f4892442 SP	251	is $ans, 'y', "prompt() doesn't require default for interactive builds";
dc8021d3	252
77e96e88	253	$ans = $mb->y_n('Say yes');
f4892442 SP	254	print "\n"; # fake <enter> after input
f4892442 SP	255	ok $ans, "y_n() doesn't require default for interactive build";
dc8021d3 SP	256
dc8021d3 SP	257
f4892442 SP	258	# Test Defaults
f4892442 SP	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 SP	268	ok $ans, " y_n() with a default";
f4892442 SP	269	}
77e96e88	270
dc8021d3	271	}
bb4e9162 YST	272
	273	# cleanup
	274	chdir( $cwd ) or die "Can''t chdir to '$cwd': $!";
	275	$dist->remove;
	276
	277	use File::Path;
	278	rmtree( $tmp );