X-Git-Url: http://vcs.maemo.org/git/?a=blobdiff_plain;f=dev%2Fi386%2Flibmodule-build-perl%2Flibmodule-build-perl-0.2808.01%2Ft%2Fextend.t;fp=dev%2Fi386%2Flibmodule-build-perl%2Flibmodule-build-perl-0.2808.01%2Ft%2Fextend.t;h=a6e27e4a1881f45e4d57ad09f16e4192d0d32d0f;hb=8977e561d8a9eae6959218b0306c9df2056a38a9;hp=0000000000000000000000000000000000000000;hpb=df794b845212301ea0d267c919232538bfef356a;p=dh-make-perl diff --git a/dev/i386/libmodule-build-perl/libmodule-build-perl-0.2808.01/t/extend.t b/dev/i386/libmodule-build-perl/libmodule-build-perl-0.2808.01/t/extend.t new file mode 100644 index 0000000..a6e27e4 --- /dev/null +++ b/dev/i386/libmodule-build-perl/libmodule-build-perl-0.2808.01/t/extend.t @@ -0,0 +1,283 @@ +#!/usr/bin/perl -w + +use strict; +use lib $ENV{PERL_CORE} ? '../lib/Module/Build/t/lib' : 't/lib'; +use MBTest tests => 65; + +use Cwd (); +my $cwd = Cwd::cwd; +my $tmp = MBTest->tmpdir; + +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?') }; + print "\n"; # fake because the prompt prints before the checks + like $@, qr/ERROR:/, + 'Do not allow default-less y_n() for unattended builds'; + + eval{ $ans = $mb->prompt('Is this a question?') }; + print "\n"; # fake because the prompt prints before the checks + 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 after input + is $ans, 'y', "prompt() doesn't require default for interactive builds"; + + $ans = $mb->y_n('Say yes'); + print "\n"; # fake 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"; + + my @ans = $mb->prompt("Is this a question", undef); + is_deeply([@ans], [undef], " prompt() with undef() default"); + } + +} + +# cleanup +chdir( $cwd ) or die "Can''t chdir to '$cwd': $!"; +$dist->remove; + +use File::Path; +rmtree( $tmp );