diff options
Diffstat (limited to 't')
60 files changed, 7856 insertions, 0 deletions
diff --git a/t/00-compile.t b/t/00-compile.t new file mode 100644 index 0000000..21bae84 --- /dev/null +++ b/t/00-compile.t @@ -0,0 +1,17 @@ +use strict; +use warnings; +use lib 't/lib'; +use MBTest; +use File::Find qw/find/; + +my @files; +find( sub { -f && /\.pm$/ && push @files, $File::Find::name }, 'lib' ); + +plan tests => scalar @files; + +for my $f ( sort @files ) { + my $ec; + my $output = stdout_stderr_of( sub { $ec = system( $^X, '-c', $f ) } ); + ok( ! $ec, "compiling $f" ) or diag $output; +} + diff --git a/t/PL_files.t b/t/PL_files.t new file mode 100644 index 0000000..68614c8 --- /dev/null +++ b/t/PL_files.t @@ -0,0 +1,86 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest tests => 8; +use DistGen; +blib_load('Module::Build'); + +my $dist; + +# Test that PL files don't get installed even in bin or lib +{ + $dist = DistGen->new( dir => MBTest->tmpdir ); + $dist->regen; + $dist->chdir_in; + + my $distname = $dist->name; + $dist->change_build_pl({ + module_name => $distname, + PL_files => { + 'bin/foo.PL' => 'bin/foo', + 'lib/Bar.pm.PL' => 'lib/Bar.pm', + }, + }); + + $dist->add_file("bin/foo.PL", <<'END'); +open my $fh, ">", $ARGV[0] or die $!; +print $fh "foo\n"; +END + + $dist->add_file("lib/Bar.pm.PL", <<'END'); +open my $fh, ">", $ARGV[0] or die $!; +print $fh "bar\n"; +END + + $dist->regen; + + my $mb = Module::Build->new_from_context( install_base => "test_install" ); + $mb->dispatch("install"); + + ok -e "test_install/bin/foo", "Generated PL_files installed from bin"; + ok -e "test_install/lib/perl5/Bar.pm", " and from lib"; + + ok !-e "test_install/bin/foo.PL", "PL_files not installed from bin"; + ok !-e "test_install/lib/perl5/Bar.pm.PL", " nor from lib"; + + is slurp("test_install/bin/foo"), "foo\n", "Generated bin contains correct content"; + is slurp("test_install/lib/perl5/Bar.pm"), "bar\n", " so does the lib"; + + $dist->chdir_original if $dist->did_chdir; +} + +# Test an empty PL target list runs the PL but doesn't +# add it to MANIFEST or cleanup +{ + $dist = DistGen->new( dir => MBTest->tmpdir ); + $dist->regen; + $dist->chdir_in; + + my $distname = $dist->name; + $dist->change_build_pl({ + module_name => $distname, + PL_files => { + 'Special.PL' => [], + }, + }); + + $dist->add_file("Special.PL", <<'END'); +open my $fh, ">", "foo" or die $!; +print $fh "foo\n"; +END + + $dist->regen; + + my $mb = Module::Build->new_from_context(); + $mb->dispatch("code"); + + ok( -f "foo", "special PL file ran" ); + + my $cleanup = $mb->cleanup; + + my %cleanup = map { $_ => 1 } $mb->cleanup; + is($cleanup{foo}, undef, "generated special file not added to cleanup"); + + $dist->chdir_original if $dist->did_chdir; +} diff --git a/t/README.pod b/t/README.pod new file mode 100644 index 0000000..b2d0579 --- /dev/null +++ b/t/README.pod @@ -0,0 +1,94 @@ +=head1 A GUIDE TO WRITING TESTS FOR MODULE::BUILD + +This document provides tips on writing new tests for Module::Build. Please +note that many existing tests were written prior to these guidelines and +have many different styles. Please don't copy/paste old tests by rote without +considering better ways to test. See C<sample.t> for a starter test file. + +=head1 TEST FILE PREAMBLE + +Every Module::Build test should begin with the same preamble to ensure that the +test library is set properly and that the correct version of Module::Build is +being tested. + + use strict; + use lib 't/lib'; + use MBTest tests => 2; # or 'no_plan' + + blib_load('Module::Build'); + +The C<MBTest> module is in C<t/lib/> and subclasses Test::More. When loaded +it cleans up several environment variables that could cause problems, +tweaks C<@INC> and exports several helper functions. See that module for +details. + +=head1 CREATING A TEST DISTRIBUTION + +The C<DistGen> module in C<t/lib/> should be used to create sample +distributions for testing. It provides numerous helpful methods to +create a skeleton distribution, add files, change files, and so on. +Run C<perldoc> on C<t/lib/DistGen.pm> to see the documentation. + + # CREATE A TEST DISTRIBUTION + + use DistGen; + + # create dist object in a temp directory + my $dist = DistGen->new; + + # enter the test distribution directory before further testing + $dist->chdir_in; + + # generate the skeleton files + $dist->regen; + + +=head1 GETTING A MODULE::BUILD OBJECT + +From inside the test distribution, you can get the Module::Build object +configured in Build.PL using the C<new_from_context> method on the +dist object. This is just like Module::Build's C<new_from_context> except +it passes C<< quiet => 1 >> to avoid sending output to the terminal. +Use the Module::Build object to test the programmatic API. + + my $mb = $dist->new_from_context( quiet => 1 ); + isa_ok( $mb, "Module::Build" ); + is( $mb->dist_name, "Simple", "dist_name is 'Simple'" ); + +=head1 TESTING THE COMMAND LINE API + +The command line API is tested by running subprocesses, not via a Module::Build +object. The C<DistGen> object has helper methods for running C<Build.PL> and +C<Build> and passing arguments on the command line. + + $dist->run_build_pl( '--quiet' ); + $dist->run_build( 'test' ); + +=head1 TYPICAL TESTING CYCLE + +The typical testing cycle is to generate or modify a test distribution, either +through the C<DistGen> object or directly in the filesystem, then regenerate +the distribution and test it (or run command line tests and observe the +result.) + + # Modify the distribution + + $dist->change_build_pl( + { + module_name => $dist->name, + license => 'artistic', + } + ); + $dist->regen; + + # Get a new build object and test it + + $mb = $dist->new_from_context; + is( $mb->license, "artistic", "saw 'artistic' license" ); + + +=head1 COPYRIGHT + +This documentation is Copyright (C) 2009 by David Golden. You can redistribute +it and/or modify it under the same terms as Perl 5.10.0. + diff --git a/t/actions/installdeps.t b/t/actions/installdeps.t new file mode 100644 index 0000000..3bd74bc --- /dev/null +++ b/t/actions/installdeps.t @@ -0,0 +1,45 @@ +use strict; +use lib 't/lib'; +use MBTest; +use DistGen; + +plan tests => 6; + +# Ensure any Module::Build modules are loaded from correct directory +blib_load('Module::Build'); + +# create dist object in a temp directory +# enter the directory and generate the skeleton files +my $dist = DistGen->new->chdir_in; + +$dist->change_build_pl( + module_name => $dist->name, + requires => { + 'File::Spec' => 9999, + }, + build_requires => { + 'Getopt::Long' => 9998, + }, + cpan_client => qq{"$^X"} . ' -le print($_)for($^X,@ARGV)', +)->regen; + +# get a Module::Build object and test with it +my $mb; +stdout_stderr_of( sub { $mb = $dist->new_from_context('verbose' => 1) } ); +isa_ok( $mb, "Module::Build" ); +like( $mb->cpan_client, qr/^"\Q$^X\E"/, "cpan_client is mocked with perl" ); + +my $retval; +my $out = stdout_of( sub { + $retval = $mb->dispatch('installdeps') +}); +ok( $retval, "ran mocked Build installdeps"); +like( $out, qr/File::Spec/, "saw File::Spec prereq" ); +like( $out, qr/Getopt::Long/, "saw Getopt::Long prereq" ); + +$out = stdout_stderr_of( sub { + $retval = $mb->dispatch('installdeps', cpan_client => 'ADLKASJDFLASDJ'); +}); +ok( !$retval, "Build installdeps with bad cpan_client fails" ); + +# vim:ts=2:sw=2:et:sta:sts=2 diff --git a/t/actions/manifest_skip.t b/t/actions/manifest_skip.t new file mode 100644 index 0000000..a3677dd --- /dev/null +++ b/t/actions/manifest_skip.t @@ -0,0 +1,54 @@ +use strict; +use lib 't/lib'; +use MBTest; +use DistGen; + +plan tests => 7; + +# Ensure any Module::Build modules are loaded from correct directory +blib_load('Module::Build'); + +# create dist object in a temp directory +# enter the directory and generate the skeleton files +my $dist = DistGen->new->chdir_in; +$dist->change_build_pl( + module_name => $dist->name, + requires => { + 'File::Spec' => 9999, + }, + build_requires => { + 'Getopt::Long' => 9998, + }, + cpan_client => $^X . ' -le print($_)for($^X,@ARGV)', +)->regen; + +ok( ! -e 'MANIFEST.SKIP', "MANIFEST.SKIP doesn't exist at start" ); + +# get a Module::Build object and test with it +my $mb; +stdout_stderr_of( sub { $mb = $dist->new_from_context('verbose' => 1) } ); +isa_ok( $mb, "Module::Build" ); + +my ($out, $err) = stdout_stderr_of( sub { + $dist->run_build('manifest_skip') +}); +ok( -e 'MANIFEST.SKIP', "'Build manifest_skip' creates MANIFEST.SKIP" ); +like( $out, qr/Creating a new MANIFEST.SKIP file/, "Saw creation message"); + +# shouldn't overwrite +my $old_mtime = -M 'MANIFEST.SKIP'; +($out, $err) = stdout_stderr_of( sub { + $dist->run_build('manifest_skip') +}); +like( $err, qr/MANIFEST.SKIP already exists/, + "Running it again warns about pre-existing MANIFEST.SKIP" +); +is( -M 'MANIFEST.SKIP', $old_mtime, "File does not appear modified" ); + +# cleanup +($out, $err) = stdout_stderr_of( sub { + $dist->run_build('distclean') +}); +ok( -e 'MANIFEST.SKIP', "MANIFEST.SKIP still exists after distclean" ); + +# vim:ts=2:sw=2:et:sta:sts=2 diff --git a/t/add_property.t b/t/add_property.t new file mode 100644 index 0000000..e0b25ae --- /dev/null +++ b/t/add_property.t @@ -0,0 +1,94 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest tests => 27; +#use MBTest 'no_plan'; +use DistGen; + +blib_load 'Module::Build'; + +my $tmp = MBTest->tmpdir; +my $dist = DistGen->new( dir => $tmp ); +$dist->regen; +$dist->chdir_in; + +ADDPROP: { + package My::Build::Prop; + use base 'Module::Build'; + __PACKAGE__->add_property( 'foo' ); + __PACKAGE__->add_property( 'bar', 'howdy' ); + __PACKAGE__->add_property( 'baz', default => 'howdy' ); + __PACKAGE__->add_property( 'code', default => sub { 'yay' } ); + __PACKAGE__->add_property( + 'check', + default => sub { 'howdy' }, + check => sub { + return 1 if $_ eq 'howdy'; + shift->property_error(qq{"$_" is invalid}); + return 0; + }, + ); + __PACKAGE__->add_property( + 'hash', + default => { foo => 1 }, + check => sub { + return 1 if !defined $_ or exists $_->{foo}; + shift->property_error(qq{hash is invalid}); + return 0; + }, + ); +} + +ok my $build = My::Build::Prop->new( + 'module_name' => 'Simple', + quiet => 1, +), 'Create new build object'; + +is $build->foo, undef, 'Property "foo" should be undef'; +ok $build->foo(42), 'Set "foo"'; +is $build->foo, 42, 'Now "foo" should have new value'; + +is $build->bar, 'howdy', 'Property "bar" should be its default'; +ok $build->bar('yo'), 'Set "bar"'; +is $build->bar, 'yo', 'Now "bar" should have new value'; + +is $build->check, 'howdy', 'Property "check" should be its default'; + +eval { $build->check('yo') }; +ok my $err = $@, 'Should get an error for an invalid value'; +like $err, qr/^ERROR: "yo" is invalid/, 'It should be the correct error'; + +is $build->code, 'yay', 'Property "code" should have its code value'; + +is_deeply $build->hash, { foo => 1 }, 'Property "hash" should be default'; +is $build->hash('foo'), 1, 'Should be able to get key in hash'; +ok $build->hash( bar => 3 ), 'Add a key to the hash prop'; +is_deeply $build->hash, { foo => 1, bar => 3 }, 'New key should be in hash'; + +eval { $build->hash({ bar => 3 }) }; +ok $err = $@, 'Should get exception for assigning invalid hash'; +like $err, qr/^ERROR: hash is invalid/, 'It should be the correct error'; + +eval { $build->hash( []) }; +ok $err = $@, 'Should get exception for assigning an array for a hash'; +like $err, qr/^Unexpected arguments for property 'hash'/, + 'It should be the proper error'; +is $build->hash(undef), undef, 'Should be able to set hash to undef'; + +# Check core properties. +is $build->installdirs, 'site', 'Property "installdirs" should be default'; +ok $build->installdirs('core'), 'Set "installdirst" to "core"'; +is $build->installdirs, 'core', 'Now "installdirs" should be "core"'; + +eval { $build->installdirs('perl') }; +ok $err = $@, 'Should have caught exception setting "installdirs" to "perl"'; +like $err, qr/^ERROR: Perhaps you meant installdirs to be "core" rather than "perl"\?/, + 'And it should suggest "core" in the error message'; + +eval { $build->installdirs('foo') }; +ok $err = $@, 'Should catch exception for invalid "installdirs" value'; +like $err, qr/ERROR: installdirs must be one of "core", "site", or "vendor"/, + 'And it should suggest the proper values in the error message'; + +$dist->chdir_original if $dist->did_chdir; diff --git a/t/add_property_array.t b/t/add_property_array.t new file mode 100644 index 0000000..3b405cb --- /dev/null +++ b/t/add_property_array.t @@ -0,0 +1,16 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest tests => 1; + +blib_load 'Module::Build'; + +ADDPROP: { + package My::Build::Prop; + use base 'Module::Build'; + __PACKAGE__->add_property( 'list_property' => []); +} + +ok grep { $_ eq 'bundle_inc' } My::Build::Prop->array_properties, "has bundle_inc even after adding another array property"; + diff --git a/t/add_property_hash.t b/t/add_property_hash.t new file mode 100644 index 0000000..afd71f8 --- /dev/null +++ b/t/add_property_hash.t @@ -0,0 +1,16 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest tests => 1; + +blib_load 'Module::Build'; + +ADDPROP: { + package My::Build::Prop; + use base 'Module::Build'; + __PACKAGE__->add_property( 'hash_property' => {}); +} + +ok grep { $_ eq 'install_path' } My::Build::Prop->hash_properties, "has install_path even after adding another hash property"; + diff --git a/t/basic.t b/t/basic.t new file mode 100644 index 0000000..e26847e --- /dev/null +++ b/t/basic.t @@ -0,0 +1,234 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest tests => 58; + +blib_load('Module::Build'); + +my $tmp = MBTest->tmpdir; + +use DistGen; +my $dist = DistGen->new( dir => $tmp ); +$dist->regen; + +$dist->chdir_in; + +######################### + + +# Test object creation +{ + my $mb = Module::Build->new( module_name => $dist->name ); + ok $mb; + is $mb->module_name, $dist->name; + is $mb->build_class, 'Module::Build'; + is $mb->dist_name, $dist->name; + + $mb = Module::Build->new( dist_name => $dist->name, dist_version => 7 ); + ok $mb; + ok $mb->module_name; # Set via heuristics + is $mb->dist_name, $dist->name; +} + +# Make sure actions are defined, and known_actions works as class method +{ + my %actions = map {$_, 1} Module::Build->known_actions; + ok $actions{clean}; + ok $actions{distdir}; +} + +# Test prerequisite checking +{ + local @INC = (File::Spec->catdir( $dist->dirname, 'lib' ), @INC); + my $flagged = 0; + local $SIG{__WARN__} = sub { $flagged = 1 if $_[0] =~ /@{[$dist->name]}/}; + my $mb = Module::Build->new( + module_name => $dist->name, + requires => {$dist->name => 0}, + ); + ok ! $flagged; + ok ! $mb->prereq_failures; + $mb->dispatch('realclean'); + $dist->clean; + + $flagged = 0; + $mb = Module::Build->new( + module_name => $dist->name, + requires => {$dist->name => 3.14159265}, + ); + ok $flagged; + ok $mb->prereq_failures; + ok $mb->prereq_failures->{requires}{$dist->name}; + is $mb->prereq_failures->{requires}{$dist->name}{have}, "0.01"; + is $mb->prereq_failures->{requires}{$dist->name}{need}, "3.14159265"; + + $mb->dispatch('realclean'); + $dist->clean; + + # Make sure check_installed_status() works as a class method + my $info = Module::Build->check_installed_status('File::Spec', 0); + ok $info->{ok}; + is $info->{have}, $File::Spec::VERSION; + + # Make sure check_installed_status() works with an advanced spec + $info = Module::Build->check_installed_status('File::Spec', '> 0'); + ok $info->{ok}; + + # Use 2 lines for this, to avoid a "used only once" warning + local $Foo::Module::VERSION; + $Foo::Module::VERSION = '1.01_02'; + + $info = Module::Build->check_installed_status('Foo::Module', '1.01_02'); + ok $info->{ok} or diag($info->{message}); +} + +{ + # Make sure the correct warning message is generated when an + # optional prereq isn't installed + my $flagged = 0; + local $SIG{__WARN__} = sub { $flagged = 1 if $_[0] =~ /ModuleBuildNonExistent is not installed/}; + + my $mb = Module::Build->new( + module_name => $dist->name, + recommends => {ModuleBuildNonExistent => 3}, + ); + ok $flagged; + $dist->clean; +} + +# Test verbosity +{ + my $mb = Module::Build->new(module_name => $dist->name); + + $mb->add_to_cleanup('save_out'); + # Use uc() so we don't confuse the current test output + like uc(stdout_of( sub {$mb->dispatch('test', verbose => 1)} )), qr/^OK \d/m; + like uc(stdout_of( sub {$mb->dispatch('test', verbose => 0)} )), qr/\.\. ?OK/; + + $mb->dispatch('realclean'); + $dist->clean; +} + +# Make sure 'config' entries are respected on the command line, and that +# Getopt::Long specs work as expected. +{ + use Config; + $dist->change_build_pl + ({ + module_name => @{[$dist->name]}, + license => 'perl', + get_options => { foo => {}, + bar => { type => '+' }, + bat => { type => '=s' }, + dee => { type => '=s', + default => 'goo' + }, + } + }); + + $dist->regen; + eval {Module::Build->run_perl_script('Build.PL', [], ['--nouse-rcfile', '--config', "foocakes=barcakes", '--foo', '--bar', '--bar', '-bat=hello', 'gee=whiz', '--any', 'hey', '--destdir', 'yo', '--verbose', '1'])}; + is $@, ''; + + my $mb = Module::Build->resume; + ok $mb->valid_property('config'); + + is $mb->config('cc'), $Config{cc}; + is $mb->config('foocakes'), 'barcakes'; + + # Test args(). + is $mb->args('foo'), 1; + is $mb->args('bar'), 2, 'bar'; + is $mb->args('bat'), 'hello', 'bat'; + is $mb->args('gee'), 'whiz'; + is $mb->args('any'), 'hey'; + is $mb->args('dee'), 'goo'; + is $mb->destdir, 'yo'; + my %runtime = $mb->runtime_params; + is_deeply \%runtime, + { + verbose => 1, + destdir => 'yo', + use_rcfile => 0, + config => { foocakes => 'barcakes' }, + }; + + ok my $argsref = $mb->args; + is $argsref->{foo}, 1; + $argsref->{doo} = 'hee'; + is $mb->args('doo'), 'hee'; + ok my %args = $mb->args; + is $args{foo}, 1; + + # revert test distribution to pristine state because we modified a file + $dist->regen( clean => 1 ); +} + +# Test author stuff +{ + my $mb = Module::Build->new( + module_name => $dist->name, + dist_author => 'Foo Meister <foo@example.com>', + build_class => 'My::Big::Fat::Builder', + ); + ok $mb; + ok ref($mb->dist_author), 'dist_author converted to array if simple string'; + is $mb->dist_author->[0], 'Foo Meister <foo@example.com>'; + is $mb->build_class, 'My::Big::Fat::Builder'; +} + +# Test conversion of shell strings +{ + my $mb = Module::Build->new( + module_name => $dist->name, + dist_author => 'Foo Meister <foo@example.com>', + extra_compiler_flags => '-I/foo -I/bar', + extra_linker_flags => '-L/foo -L/bar', + ); + ok $mb; + is_deeply $mb->extra_compiler_flags, ['-I/foo', '-I/bar'], "Should split shell string into list"; + is_deeply $mb->extra_linker_flags, ['-L/foo', '-L/bar'], "Should split shell string into list"; + + # Try again with command-line args + eval {Module::Build->run_perl_script('Build.PL', [], ['--extra_compiler_flags', '-I/foo -I/bar', + '--extra_linker_flags', '-L/foo -L/bar'])}; + $mb = Module::Build->resume; + ok $mb; + is_deeply $mb->extra_compiler_flags, ['-I/foo', '-I/bar'], "Should split shell string into list"; + is_deeply $mb->extra_linker_flags, ['-L/foo', '-L/bar'], "Should split shell string into list"; +} + +# Test include_dirs. +{ + ok my $mb = Module::Build->new( + module_name => $dist->name, + include_dirs => [qw(/foo /bar)], + ); + is_deeply $mb->include_dirs, ['/foo', '/bar'], 'Should have include dirs'; + + # Try a string. + ok $mb = Module::Build->new( + module_name => $dist->name, + include_dirs => '/foo', + ); + is_deeply $mb->include_dirs, ['/foo'], 'Should have string include dir'; + + # Try again with command-line args + eval { Module::Build->run_perl_script( + 'Build.PL', [], + ['--include_dirs', '/foo', '--include_dirs', '/bar' ], + ) }; + + ok $mb = Module::Build->resume; + is_deeply $mb->include_dirs, ['/foo', '/bar'], 'Should have include dirs'; + + eval { Module::Build->run_perl_script( + 'Build.PL', [], + ['--include_dirs', '/foo' ], + ) }; + + ok $mb = Module::Build->resume; + is_deeply $mb->include_dirs, ['/foo'], 'Should have single include dir'; +} + diff --git a/t/bundle_inc.t b/t/bundle_inc.t new file mode 100644 index 0000000..00dcf47 --- /dev/null +++ b/t/bundle_inc.t @@ -0,0 +1,222 @@ +# sample.t -- a sample test file for Module::Build + +use strict; +use lib 't/lib'; +use MBTest; # or 'no_plan' +use DistGen; +use Config; +use File::Spec; +use ExtUtils::Packlist; +use ExtUtils::Installed; +use File::Path; + +# Ensure any Module::Build modules are loaded from correct directory +blib_load('Module::Build'); +blib_load('Module::Build::ConfigData'); + +if ( $ENV{PERL_CORE} ) { + plan skip_all => 'bundle_inc tests will never succeed in PERL_CORE'; +} +elsif ( ! $ENV{MB_TEST_EXPERIMENTAL} ) { + plan skip_all => '$ENV{MB_TEST_EXPERIMENTAL} is not set'; +} +elsif ( ! MBTest::check_EUI() ) { + plan skip_all => 'ExtUtils::Installed takes too long on your system'; +} +elsif ( Module::Build::ConfigData->feature('inc_bundling_support') ) { + plan tests => 19; +} else { + plan skip_all => 'inc_bundling_support feature is not enabled'; +} + +# need to do a temp install of M::B being tested to ensure a packlist +# is available for bundling + +my $current_mb = Module::Build->resume(); +my $temp_install = MBTest->tmpdir(); +my $arch = $Config{archname}; +my $lib_path = File::Spec->catdir($temp_install,qw/lib perl5/); +my $arch_path = File::Spec->catdir( $lib_path, $arch ); +mkpath ( $arch_path ); +ok( -d $arch_path, "created temporary M::B pseudo-install directory"); + +unshift @INC, $lib_path, $arch_path; +local $ENV{PERL5LIB} = join( $Config{path_sep}, + $lib_path, ($ENV{PERL5LIB} ? $ENV{PERL5LIB} : () ) +); + +# must uninst=0 so we don't try to remove an installed M::B! +stdout_of( sub { $current_mb->dispatch( + 'install', install_base => $temp_install, uninst => 0 + ) + } +); + +# create dist object in a temp directory +# enter the directory and generate the skeleton files +my $dist = DistGen->new( inc => 1 )->chdir_in->regen; + +# get a Module::Build object and test with it +my $mb = $dist->new_from_context(); # quiet by default +isa_ok( $mb, "Module::Build" ); +is( $mb->dist_name, "Simple", "dist_name is 'Simple'" ); +is_deeply( $mb->bundle_inc, [ 'Module::Build' ], + "Module::Build is flagged for bundling" +); + +# bundle stuff into distdir +stdout_stderr_of( sub { $mb->dispatch('distdir') } ); + +my $dist_inc = File::Spec->catdir($mb->dist_dir, 'inc'); +ok( -e File::Spec->catfile( $dist_inc, 'latest.pm' ), + "dist_dir/inc/latest.pm created" +); + +ok( -d File::Spec->catdir( $dist_inc, 'inc_Module-Build' ), + "dist_dir/inc/inc_Module_Build created" +); + +my $mb_file = + File::Spec->catfile( $dist_inc, qw/inc_Module-Build Module Build.pm/ ); + +ok( -e $mb_file, + "dist_dir/inc/inc_Module_Build/Module/Build.pm created" +); + +ok( -e File::Spec->catfile( $dist_inc, qw/inc_Module-Build Module Build Base.pm/ ), + "dist_dir/inc/inc_Module_Build/Module/Build/Base.pm created" +); + +# Force bundled M::B to a higher version so it gets loaded +# This has failed on Win32 for no known reason, so we'll skip if +# we can't edit the file. + +eval { + chmod 0666, $mb_file; + open(my $fh, '<', $mb_file) or die "Could not read $mb_file: $!"; + my $mb_code = do { local $/; <$fh> }; + $mb_code =~ s{\$VERSION\s+=\s+\S+}{\$VERSION = 9999;}; + close $fh; + open($fh, '>', $mb_file) or die "Could not write $mb_file: $!"; + print {$fh} $mb_code; + close $fh; +}; + +my $err = $@; +diag $@ if $@; +SKIP: { + skip "Couldn't adjust \$VERSION in bundled M::B for testing", 10 + if $err; + + # test the bundling in dist_dir + chdir $mb->dist_dir; + + stdout_of( sub { Module::Build->run_perl_script('Build.PL',[],[]) } ); + ok( -e 'MYMETA.yml', 'MYMETA was created' ); + + open(my $meta, '<', 'MYMETA.yml'); + ok( $meta, "opened MYMETA.yml" ); + ok( scalar( grep { /generated_by:.*9999/ } <$meta> ), + "dist_dir Build.PL loaded bundled Module::Build" + ); + close $meta; + + #--------------------------------------------------------------------------# + # test identification of dependencies + #--------------------------------------------------------------------------# + + $dist->chdir_in; + + $dist->add_file( 'mylib/Foo.pm', << 'HERE' ); +package Foo; +our $VERSION = 1; +1; +HERE + + $dist->add_file( 'mylib/Bar.pm', << 'HERE' ); +package Bar; +use Foo; +our $VERSION = 42; +1; +HERE + + $dist->change_file( 'Build.PL', << "HERE" ); +use inc::latest 'Module::Build'; +use inc::latest 'Foo'; + +Module::Build->new( + module_name => '$dist->{name}', + license => 'perl', +)->create_build_script; +HERE + + $dist->regen( clean => 1 ); + + make_packlist($_,'mylib') for qw/Foo Bar/; + + # get a Module::Build object and test with it + my $abs_mylib = File::Spec->rel2abs('mylib'); + + + unshift @INC, $abs_mylib; + $mb = $dist->new_from_context(); # quiet by default + isa_ok( $mb, "Module::Build" ); + is_deeply( [sort @{$mb->bundle_inc}], [ 'Foo', 'Module::Build' ], + "Module::Build and Foo are flagged for bundling" + ); + + my $output = stdout_stderr_of( sub { $mb->dispatch('distdir') } ); + + ok( -e File::Spec->catfile( $dist_inc, 'latest.pm' ), + "./inc/latest.pm created" + ); + + ok( -d File::Spec->catdir( $dist_inc, 'inc_Foo' ), + "dist_dir/inc/inc_Foo created" + ); + + $dist->change_file( 'Build.PL', << "HERE" ); +use inc::latest 'Module::Build'; +use inc::latest 'Bar'; + +Module::Build->new( + module_name => '$dist->{name}', + license => 'perl', +)->create_build_script; +HERE + + $dist->regen( clean => 1 ); + make_packlist($_,'mylib') for qw/Foo Bar/; + + $mb = $dist->new_from_context(); # quiet by default + isa_ok( $mb, "Module::Build" ); + is_deeply( [sort @{$mb->bundle_inc}], [ 'Bar', 'Module::Build' ], + "Module::Build and Bar are flagged for bundling" + ); + + $output = stdout_stderr_of( sub { $mb->dispatch('distdir') } ); + + ok( -e File::Spec->catfile( $dist_inc, 'latest.pm' ), + "./inc/latest.pm created" + ); + + ok( -d File::Spec->catdir( $dist_inc, 'inc_Bar' ), + "dist_dir/inc/inc_Bar created" + ); +} + + +sub make_packlist { + my ($mod, $lib) = @_; + my $arch = $Config{archname}; + (my $mod_path = $mod) =~ s{::}{/}g; + my $mod_file = File::Spec->catfile( $lib, "$mod_path\.pm" ); + my $abs = File::Spec->rel2abs($mod_file); + my $packlist_path = File::Spec->catdir($lib, $arch, 'auto', $mod_path); + mkpath $packlist_path; + my $packlist = ExtUtils::Packlist->new; + $packlist->{$abs}++; + $packlist->write( File::Spec->catfile( $packlist_path, '.packlist' )); +} + +# vim:ts=2:sw=2:et:sta:sts=2 diff --git a/t/bundled/Software/License.pm b/t/bundled/Software/License.pm new file mode 100644 index 0000000..6457ab6 --- /dev/null +++ b/t/bundled/Software/License.pm @@ -0,0 +1,56 @@ +# Modified from the original as a "mock" version for testing +use strict; +use warnings; +use 5.006; # warnings +package Software::License; +our $VERSION = 9999; + +sub new { + my ($class, $arg) = @_; + + # XXX changed from Carp::croak to die + die "no copyright holder specified" unless $arg->{holder}; + + bless $arg => $class; +} + + +sub year { defined $_[0]->{year} ? $_[0]->{year} : (localtime)[5]+1900 } +sub holder { $_[0]->{holder} } + +sub version { + my ($self) = @_; + my $pkg = ref $self ? ref $self : $self; + $pkg =~ s/.+:://; + my (undef, @vparts) = split /_/, $pkg; + + return unless @vparts; + return join '.', @vparts; +} + + +# sub meta1_name { return undef; } # sort this out later, should be easy +sub meta_name { return undef; } +sub meta_yml_name { $_[0]->meta_name } + +sub meta2_name { + my ($self) = @_; + my $meta1 = $self->meta_name; + + return undef unless defined $meta1; + + return $meta1 + if $meta1 =~ /\A(?:open_source|restricted|unrestricted|unknown)\z/; + + return undef; +} + +# XXX these are trivial mocks of the real thing +sub notice { 'NOTICE' } +sub license { 'LICENSE' } +sub fulltext { 'FULLTEXT' } + +1; + + + diff --git a/t/bundled/Tie/CPHash.pm b/t/bundled/Tie/CPHash.pm new file mode 100644 index 0000000..b167622 --- /dev/null +++ b/t/bundled/Tie/CPHash.pm @@ -0,0 +1,194 @@ +#--------------------------------------------------------------------- +package Tie::CPHash; +# +# Copyright 1997 Christopher J. Madsen +# +# Author: Christopher J. Madsen <cjm@pobox.com> +# Created: 08 Nov 1997 +# $Revision$ $Date$ +# +# This program is free software; you can redistribute it and/or modify +# it under the same terms as Perl itself. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the +# GNU General Public License or the Artistic License for more details. +# +# Case preserving but case insensitive hash +#--------------------------------------------------------------------- + +require 5.000; +use strict; +use vars qw(@ISA $VERSION); + +@ISA = qw(); + +#===================================================================== +# Package Global Variables: + +$VERSION = '1.02'; + +#===================================================================== +# Tied Methods: +#--------------------------------------------------------------------- +# TIEHASH classname +# The method invoked by the command `tie %hash, classname'. +# Associates a new hash instance with the specified class. + +sub TIEHASH +{ + bless {}, $_[0]; +} # end TIEHASH + +#--------------------------------------------------------------------- +# STORE this, key, value +# Store datum *value* into *key* for the tied hash *this*. + +sub STORE +{ + $_[0]->{lc $_[1]} = [ $_[1], $_[2] ]; +} # end STORE + +#--------------------------------------------------------------------- +# FETCH this, key +# Retrieve the datum in *key* for the tied hash *this*. + +sub FETCH +{ + my $v = $_[0]->{lc $_[1]}; + ($v ? $v->[1] : undef); +} # end FETCH + +#--------------------------------------------------------------------- +# FIRSTKEY this +# Return the (key, value) pair for the first key in the hash. + +sub FIRSTKEY +{ + my $a = scalar keys %{$_[0]}; + &NEXTKEY; +} # end FIRSTKEY + +#--------------------------------------------------------------------- +# NEXTKEY this, lastkey +# Return the next (key, value) pair for the hash. + +sub NEXTKEY +{ + my $v = (each %{$_[0]})[1]; + ($v ? $v->[0] : undef ); +} # end NEXTKEY + +#--------------------------------------------------------------------- +# SCALAR this +# Return bucket usage information for the hash (0 if empty). + +sub SCALAR +{ + scalar %{$_[0]}; +} # end SCALAR + +#--------------------------------------------------------------------- +# EXISTS this, key +# Verify that *key* exists with the tied hash *this*. + +sub EXISTS +{ + exists $_[0]->{lc $_[1]}; +} # end EXISTS + +#--------------------------------------------------------------------- +# DELETE this, key +# Delete the key *key* from the tied hash *this*. +# Returns the old value, or undef if it didn't exist. + +sub DELETE +{ + my $v = delete $_[0]->{lc $_[1]}; + ($v ? $v->[1] : undef); +} # end DELETE + +#--------------------------------------------------------------------- +# CLEAR this +# Clear all values from the tied hash *this*. + +sub CLEAR +{ + %{$_[0]} = (); +} # end CLEAR + +#===================================================================== +# Other Methods: +#--------------------------------------------------------------------- +# Return the case of KEY. + +sub key +{ + my $v = $_[0]->{lc $_[1]}; + ($v ? $v->[0] : undef); +} + +#===================================================================== +# Package Return Value: + +1; + +__END__ + +=head1 NAME + +Tie::CPHash - Case preserving but case insensitive hash table + +=head1 SYNOPSIS + + require Tie::CPHash; + tie %cphash, 'Tie::CPHash'; + + $cphash{'Hello World'} = 'Hi there!'; + printf("The key `%s' was used to store `%s'.\n", + tied(%cphash)->key('HELLO WORLD'), + $cphash{'HELLO world'}); + +=head1 DESCRIPTION + +The B<Tie::CPHash> module provides a hash table that is case +preserving but case insensitive. This means that + + $cphash{KEY} $cphash{key} + $cphash{Key} $cphash{keY} + +all refer to the same entry. Also, the hash remembers which form of +the key was last used to store the entry. The C<keys> and C<each> +functions will return the key that was used to set the value. + +An example should make this clear: + + tie %h, 'Tie::CPHash'; + $h{Hello} = 'World'; + print $h{HELLO}; # Prints 'World' + print keys(%h); # Prints 'Hello' + $h{HELLO} = 'WORLD'; + print $h{hello}; # Prints 'WORLD' + print keys(%h); # Prints 'HELLO' + +The additional C<key> method lets you fetch the case of a specific key: + + # When run after the previous example, this prints 'HELLO': + print tied(%h)->key('Hello'); + +(The C<tied> function returns the object that C<%h> is tied to.) + +If you need a case insensitive hash, but don't need to preserve case, +just use C<$hash{lc $key}> instead of C<$hash{$key}>. This has a lot +less overhead than B<Tie::CPHash>. + +=head1 AUTHOR + +Christopher J. Madsen E<lt>F<cjm@pobox.com>E<gt> + +=cut + +# Local Variables: +# tmtrack-file-task: "Tie::CPHash.pm" +# End: diff --git a/t/compat.t b/t/compat.t new file mode 100644 index 0000000..101f573 --- /dev/null +++ b/t/compat.t @@ -0,0 +1,563 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest; +use File::Spec; +use Config; + +# Don't let our own verbosity/test_file get mixed up with our subprocess's +my @makefile_keys = qw(TEST_VERBOSE HARNESS_VERBOSE TEST_FILES MAKEFLAGS); +local @ENV{@makefile_keys}; +delete @ENV{@makefile_keys}; + +my @makefile_types = qw(small passthrough traditional); +my $tests_per_type = 15; + +#find_in_path does not understand VMS. + +if ( $Config{make} && $^O ne 'VMS' ? find_in_path($Config{make}) : 1 ) { + plan 'no_plan'; +} else { + plan skip_all => "Don't know how to invoke 'make'"; +} + +my $is_vms_mms = ($^O eq 'VMS') && ($Config{make} =~ /MM[SK]/i); + +blib_load('Module::Build'); + + +######################### + +my $tmp = MBTest->tmpdir; + +# Create test distribution; set requires and build_requires +use DistGen; +my $dist = DistGen->new( dir => $tmp ); +$dist->regen; + +$dist->chdir_in; + + +######################### + +blib_load('Module::Build'); +blib_load('Module::Build::Compat'); + +use Carp; $SIG{__WARN__} = \&Carp::cluck; + +my @make = $Config{make} eq 'nmake' ? ('nmake', '-nologo') : ($Config{make}); + +my $makefile = 'Makefile'; + +# VMS MMK/MMS by convention use Descrip.MMS +if ($is_vms_mms) { + $makefile = 'Descrip.MMS'; +} + + +######################### + +# Test without requires + +test_makefile_types(); + +# Test with requires and PL_files + +my $distname = $dist->name; +$dist->change_build_pl({ + module_name => $distname, + license => 'perl', + requires => { + 'perl' => $], + 'File::Spec' => 0.2, + }, + build_requires => { + 'Test::More' => 0, + 'File::Spec' => 0, + }, + PL_files => { 'foo.PL' => 'foo' }, +}); + +$dist->add_file("foo.PL", <<'END'); +open my $fh, ">$ARGV[0]" or die $!; +print $fh "foo\n"; +END + +$dist->regen; + +test_makefile_types( + requires => { + 'perl' => $], + 'File::Spec' => 0.2, + }, + build_requires => { + 'Test::More' => 0, + 'File::Spec' => 0, + }, + PL_files => { + 'foo.PL' => 'foo', + }, +); + +###################### + +$dist->change_build_pl({ + module_name => $distname, + license => 'perl', +}); +$dist->regen; + +# Create M::B instance but don't pollute STDOUT +my $mb; +stdout_stderr_of( sub { + $mb = Module::Build->new_from_context; +}); +ok $mb, "Module::Build->new_from_context"; + + +{ + # Make sure fake_makefile() can run without 'build_class', as it may be + # in older-generated Makefile.PLs + my $warning = ''; + local $SIG{__WARN__} = sub { $warning = shift; }; + + my $maketext = eval { Module::Build::Compat->fake_makefile(makefile => $makefile) }; + is $@, '', "fake_makefile lived"; + like $maketext, qr/^realclean/m, "found 'realclean' in fake_makefile output"; + like $warning, qr/build_class/, "saw warning about 'build_class'"; +} + +{ + # Make sure custom builder subclass is used in the created + # Makefile.PL - make sure it fails in the right way here. + local @Foo::Builder::ISA = qw(Module::Build); + my $foo_builder; + stdout_stderr_of( sub { + $foo_builder = Foo::Builder->new_from_context; + }); + foreach my $style ('passthrough', 'small') { + create_makefile_pl($style, $foo_builder); + + # Should fail with "can't find Foo/Builder.pm" + my $result; + my ($stdout, $stderr ) = stdout_stderr_of (sub { + $result = $mb->run_perl_script('Makefile.PL'); + }); + ok ! $result, "Makefile.PL failed"; + like $stderr, qr{Foo/Builder.pm}, "custom builder wasn't found"; + } + + # Now make sure it can actually work. + my $bar_builder; + stdout_stderr_of( sub { + $bar_builder = Module::Build->subclass( class => 'Bar::Builder' )->new_from_context; + }); + foreach my $style ('passthrough', 'small') { + create_makefile_pl($style, $bar_builder); + my $result; + stdout_stderr_of( sub { + $result = $mb->run_perl_script('Makefile.PL'); + }); + ok $result, "Makefile.PL ran without error"; + } +} + +{ + # Make sure various Makefile.PL arguments are supported + create_makefile_pl('passthrough', $mb); + + my $libdir = File::Spec->catdir( $tmp, 'libdir' ); + my $result; + stdout_stderr_of( sub { + $result = $mb->run_perl_script('Makefile.PL', [], + [ + "LIB=$libdir", + 'TEST_VERBOSE=1', + 'INSTALLDIRS=perl', + 'POLLUTE=1', + ] + ); + }); + ok $result, "passthrough Makefile.PL ran with arguments"; + ok -e 'Build.PL', "Build.PL generated"; + + my $new_build = Module::Build->resume(); + is $new_build->installdirs, 'core', "installdirs is core"; + is $new_build->verbose, 1, "tests set for verbose"; + is $new_build->install_destination('lib'), $libdir, "custom libdir"; + is $new_build->extra_compiler_flags->[0], '-DPERL_POLLUTE', "PERL_POLLUTE set"; + + # Make sure those switches actually had an effect + my ($ran_ok, $output); + $output = stdout_stderr_of( sub { $ran_ok = $new_build->do_system(@make, 'test') } ); + ok $ran_ok, "make test ran without error"; + $output =~ s/^/# /gm; # Don't confuse our own test output + like $output, qr/(?:# ok \d+\s+)+/, 'Should be verbose'; + + # Make sure various Makefile arguments are supported + my $make_macro = 'TEST_VERBOSE=0'; + + # VMS MMK/MMS macros use different syntax. + if ($is_vms_mms) { + $make_macro = '/macro=("' . $make_macro . '")'; + } + + $output = stdout_stderr_of( sub { + local $ENV{HARNESS_TIMER}; # RT#39635 - timer messes with output + $ran_ok = $mb->do_system(@make, 'test', $make_macro) + } ); + + ok $ran_ok, "make test without verbose ran ok"; + $output =~ s/^/# /gm; # Don't confuse our own test output + like $output, + qr/# .+basic(\.t)?[.\s#]+ok[.\s#]+All tests successful/, + 'Should be non-verbose'; + + (my $libdir2 = $libdir) =~ s/libdir/lbiidr/; + my $libarch2 = File::Spec->catdir($libdir2, 'arch'); + my $check_base = $libdir2; + $check_base =~ s/\]\z// if $^O eq 'VMS'; # trim trailing ] for appending other dirs + + SKIP: { + my @cases = ( + { + label => "INSTALLDIRS=vendor", + args => [ 'INSTALLDIRS=vendor', "INSTALLVENDORLIB=$libdir2", "INSTALLVENDORARCH=$libarch2"], + check => qr/\Q$check_base\E .* Simple\.pm/ix, + }, + { + label => "PREFIX=\$libdir2", + args => [ "PREFIX=$libdir2"], + check => qr/\Q$check_base\E .* Simple\.pm/ix, + }, + { + label => "PREFIX=\$libdir2 LIB=mylib", + args => [ "PREFIX=$libdir2", "LIB=mylib" ], + check => qr{\Q$check_base\E[/\\\.]mylib[/\\\]]Simple\.pm}ix, + }, + ); + + require ExtUtils::Install; + skip "Needs ExtUtils::Install 1.32 or later", 2 * @cases + if ExtUtils::Install->VERSION < 1.32; + + for my $c (@cases) { + my @make_args = @{$c->{args}}; + ($output) = stdout_stderr_of( + sub { + $result = $mb->run_perl_script('Makefile.PL', [], \@make_args); + $ran_ok = $mb->do_system(@make, 'fakeinstall'); + } + ); + + ok $ran_ok, "fakeinstall $c->{label} ran ok"; + $output =~ s/^/# /gm; # Don't confuse our own test output + like $output, $c->{check}, + "Saw destination directory for $c->{label}"; + } + } + + stdout_stderr_of( sub { $mb->do_system(@make, 'realclean'); } ); + ok ! -e $makefile, "$makefile shouldn't exist"; + + 1 while unlink 'Makefile.PL'; + ok ! -e 'Makefile.PL', "Makefile.PL cleaned up"; + + 1 while unlink $libdir, $libdir2; +} + +{ # Make sure tilde-expansion works + + # C<glob> on MSWin32 uses $ENV{HOME} if defined to do tilde-expansion + local $ENV{HOME} = 'C:/' if $^O =~ /MSWin/ && !exists( $ENV{HOME} ); + + create_makefile_pl('passthrough', $mb); + + stdout_stderr_of( sub { + $mb->run_perl_script('Makefile.PL', [], ['INSTALL_BASE=~/foo']); + }); + my $b2 = Module::Build->current; + ok $b2->install_base, "install_base set"; + unlike $b2->install_base, qr/^~/, "Tildes should be expanded"; + + stdout_stderr_of( sub { $mb->do_system(@make, 'realclean'); } ); + ok ! -e $makefile, "$makefile shouldn't exist"; + + 1 while unlink 'Makefile.PL'; + ok ! -e 'Makefile.PL', "Makefile.PL cleaned up"; +} + +{ + $dist->add_file('t/deep/foo.t', q{}); + $dist->regen; + + my $mb; + stdout_stderr_of( sub { + $mb = Module::Build->new_from_context( recursive_test_files => 1 ); + }); + + create_makefile_pl('traditional', $mb); + my $args = extract_writemakefile_args() || {}; + + if ( exists $args->{test}->{TESTS} ) { + is $args->{test}->{TESTS}, + join( q{ }, + File::Spec->catfile(qw(t *.t)), + File::Spec->catfile(qw(t deep *.t)) + ), + 'Makefile.PL has correct TESTS line for recursive test files'; + } else { + ok( ! exists $args->{TESTS}, 'Not using incorrect recursive tests key' ); + } + + 1 while unlink 'Makefile.PL'; + ok ! -e 'Makefile.PL', "Makefile.PL cleaned up"; +} + +{ + # make sure using prereq with '0.1.2' complains + $dist->change_build_pl({ + module_name => $distname, + license => 'perl', + requires => { + 'Foo::Frobnicate' => '0.1.2', + }, + create_makefile_pl => 'traditional', + }); + $dist->regen; + + my $mb; + stdout_stderr_of( sub { + $mb = Module::Build->new_from_context; + }); + + my $output = stdout_stderr_of( sub { $mb->do_create_makefile_pl } ); + ok -e 'Makefile.PL', "Makefile.PL created"; + like $output, qr/is not portable/, "Correctly complains and converts dotted-decimal"; + + my $file_contents = slurp 'Makefile.PL'; + like $file_contents, qr/Foo::Frobnicate.+0\.001002/, "Properly converted dotted-decimal"; + + 1 while unlink 'Makefile.PL'; + ok ! -e 'Makefile.PL', "Makefile.PL cleaned up"; +} + +{ + # make sure using invalid prereq blows up + $dist->change_build_pl({ + module_name => $distname, + license => 'perl', + requires => { + 'Foo::Frobnicate' => '3.5_2_7', + }, + create_makefile_pl => 'traditional', + }); + $dist->regen; + + ok ! -e 'Makefile.PL', "Makefile.PL doesn't exist before we start"; + + my $mb; + stdout_stderr_of( sub { + $mb = $dist->run_build_pl; + }); + + my ($output, $error) = stdout_stderr_of( sub { $dist->run_build('distmeta') } ); + like $error, qr/is not supported/ms, "Correctly dies when it encounters invalid prereq"; + ok ! -e 'Makefile.PL', "Makefile.PL NOT created"; + + 1 while unlink 'Makefile.PL'; + ok ! -e 'Makefile.PL', "Makefile.PL cleaned up"; +} + +######################################################### + +sub _merge_prereqs { + my ($first, $second) = @_; + my $new = { %$first }; + for my $k (keys %$second) { + if ( exists $new->{$k} ) { + my ($v1,$v2) = ($new->{$k},$second->{$k}); + $new->{$k} = ($v1 > $v2 ? $v1 : $v2); + } + else { + $new->{$k} = $second->{$k}; + } + } + return $new; +} + +sub test_makefile_types { + my %opts = @_; + $opts{requires} ||= {}; + $opts{build_requires} ||= {}; + $opts{PL_files} ||= {}; + + foreach my $type (@makefile_types) { + # Create M::B instance + my $mb; + stdout_stderr_of( sub { + $mb = Module::Build->new_from_context; + }); + ok $mb, "Module::Build->new_from_context"; + + # Create and test Makefile.PL + create_makefile_pl($type, $mb); + + test_makefile_pl_requires_perl( $opts{requires}{perl} ); + test_makefile_creation($mb); + test_makefile_prereq_pm( _merge_prereqs($opts{requires}, $opts{build_requires}) ); + test_makefile_pl_files( $opts{PL_files} ) if $type eq 'traditional'; + + my ($output,$success); + # Capture output to keep our STDOUT clean + $output = stdout_stderr_of( sub { + $success = $mb->do_system(@make); + }); + ok $success, "make ran without error"; + + for my $file (values %{ $opts{PL_files} }) { + ok -e $file, "PL_files generated - $file"; + } + + # Can't let 'test' STDOUT go to our STDOUT, or it'll confuse Test::Harness. + $output = stdout_stderr_of( sub { + $success = $mb->do_system(@make, 'test'); + }); + ok $success, "make test ran without error"; + like uc $output, qr{DONE\.|SUCCESS}, "make test output indicated success"; + + $output = stdout_stderr_of( sub { + $success = $mb->do_system(@make, 'realclean'); + }); + ok $success, "make realclean ran without error"; + + # Try again with some Makefile.PL arguments + test_makefile_creation($mb, [], 'INSTALLDIRS=vendor', 'realclean'); + + # Try again using distclean + test_makefile_creation($mb, [], '', 'distclean'); + + 1 while unlink 'Makefile.PL'; + ok ! -e 'Makefile.PL', "cleaned up Makefile"; + } +} + +sub test_makefile_creation { + my ($build, $preargs, $postargs, $cleanup) = @_; + + my ($output, $result); + # capture output to avoid polluting our test output + $output = stdout_stderr_of( sub { + $result = $build->run_perl_script('Makefile.PL', $preargs, $postargs); + }); + my $label = "Makefile.PL ran without error"; + if ( defined $postargs && length $postargs ) { + $label .= " (postargs: $postargs)"; + } + ok $result, $label; + ok -e $makefile, "$makefile exists"; + + if ($cleanup) { + # default to 'realclean' unless we recognize the clean method + $cleanup = 'realclean' unless $cleanup =~ /^(dist|real)clean$/; + my ($stdout, $stderr ) = stdout_stderr_of (sub { + $build->do_system(@make, $cleanup); + }); + ok ! -e $makefile, "$makefile cleaned up with $cleanup"; + } + else { + pass '(skipping cleanup)'; # keep test count constant + } +} + +sub test_makefile_prereq_pm { + my %requires = %{ $_[0] }; + delete $requires{perl}; # until EU::MM supports this + SKIP: { + skip "$makefile not found", 1 unless -e $makefile; + my $prereq_pm = find_params_in_makefile()->{PREREQ_PM} || {}; + is_deeply $prereq_pm, \%requires, + "$makefile has correct PREREQ_PM line"; + } +} + +sub test_makefile_pl_files { + my $expected = shift; + + SKIP: { + skip 1, 'Makefile.PL not found' unless -e 'Makefile.PL'; + my $args = extract_writemakefile_args() || {}; + is_deeply $args->{PL_FILES}, $expected, + "Makefile.PL has correct PL_FILES line"; + } +} + +sub test_makefile_pl_requires_perl { + my $perl_version = shift || q{}; + SKIP: { + skip 1, 'Makefile.PL not found' unless -e 'Makefile.PL'; + my $file_contents = slurp 'Makefile.PL'; + my $found_requires = $file_contents =~ m{^require $perl_version;}ms; + if (length $perl_version) { + ok $found_requires, "Makefile.PL has 'require $perl_version;'" + or diag "Makefile.PL:\n$file_contents"; + } + else { + ok ! $found_requires, "Makefile.PL does not require a perl version"; + } + } +} + +sub find_params_in_makefile { + open(my $fh, '<', $makefile ) + or die "Can't read $makefile: $!"; + local($/) = "\n"; + + my %params; + while (<$fh>) { + # Blank line after params. + last if keys %params and !/\S+/; + + next unless m{^\# \s+ ( [A-Z_]+ ) \s+ => \s+ ( .* )$}x; + + my($key, $val) = ($1, $2); + # extract keys and values + while ( $val =~ m/(?:\s)(\S+)=>(q\[.*?\]|undef),?/g ) { + my($m,$n) = ($1,$2); + if ($n =~ /^q\[(.*?)\]$/) { + $n = $1; + } + $params{$key}{$m} = $n; + } + } + + return \%params; +} + +sub extract_writemakefile_args { + SKIP: { + skip 1, 'Makefile.PL not found' unless -e 'Makefile.PL'; + my $file_contents = slurp 'Makefile.PL'; + my ($args) = $file_contents =~ m{^WriteMakefile\n\((.*)\).*;}ms; + ok $args, "Found WriteMakefile arguments" + or diag "Makefile.PL:\n$file_contents"; + my %args = eval $args or diag $args; ## no critic + return \%args; + } +} + +sub create_makefile_pl { + my @args = @_; + stdout_stderr_of( sub { Module::Build::Compat->create_makefile_pl(@args) } ); + my $ok = ok -e 'Makefile.PL', "$_[0] Makefile.PL created"; + + # Some really conservative make's, like HP/UX, assume files with the same + # timestamp are out of date. Send the Makefile.PL one second into the past + # so its older than the Makefile it will generate. + # See [rt.cpan.org 45700] + my $mtime = (stat("Makefile.PL"))[9]; + utime $mtime, $mtime - 1, "Makefile.PL"; + + return $ok; +} diff --git a/t/compat/exit.t b/t/compat/exit.t new file mode 100644 index 0000000..3672c93 --- /dev/null +++ b/t/compat/exit.t @@ -0,0 +1,53 @@ +#!/usr/bin/perl -w + +use strict; + +use lib 't/lib'; +use MBTest tests => 3; + +blib_load('Module::Build'); + +######################### + +my $tmp = MBTest->tmpdir; + +# Create test distribution; set requires and build_requires +use DistGen; +my $dist = DistGen->new( dir => $tmp ); + +$dist->regen; + +$dist->chdir_in; + +######################### + +my $mb; stdout_of(sub{ $mb = Module::Build->new_from_context}); + +blib_load('Module::Build::Compat'); + +$dist->regen; + +stdout_stderr_of( + sub{ Module::Build::Compat->create_makefile_pl('passthrough', $mb); } +); + +# as silly as all of this exit(0) business is, that is what the cpan +# testers have instructed everybody to do so... +$dist->change_file('Build.PL' => + "warn qq(you have no libthbbt\n); exit;\n" . $dist->get_file('Build.PL') +); + +$dist->regen; + +stdout_of(sub{ $mb->ACTION_realclean }); + +my $result; +my ($stdout, $stderr ) = stdout_stderr_of (sub { + $result = $mb->run_perl_script('Makefile.PL'); +}); +ok $result, "Makefile.PL exit"; +like $stdout, qr/running Build\.PL/; +like $stderr, qr/you have no libthbbt$/; +#warn "out: $stdout"; warn "err: $stderr"; + +# vim:ts=2:sw=2:et:sta diff --git a/t/debug.t b/t/debug.t new file mode 100644 index 0000000..e0b8f60 --- /dev/null +++ b/t/debug.t @@ -0,0 +1,27 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest tests => 1; + +blib_load('Module::Build'); + +my $tmp = MBTest->tmpdir; + +use DistGen; +my $dist = DistGen->new( dir => $tmp ); +$dist->regen; +$dist->chdir_in; + +######################### + +# Test debug output +{ + my $output; + $output = stdout_of sub { $dist->run_build_pl }; + $output = stdout_of sub { $dist->run_build('--debug') }; + like($output, '/Starting ACTION_build.*?Starting ACTION_code.*?Finished ACTION_code.*?Finished ACTION_build/ms', + "found nested ACTION_* debug statements" + ); +} + diff --git a/t/destinations.t b/t/destinations.t new file mode 100644 index 0000000..2b9aba6 --- /dev/null +++ b/t/destinations.t @@ -0,0 +1,323 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest tests => 113; + +blib_load('Module::Build'); + +my $tmp = MBTest->tmpdir; + +use DistGen; +my $dist = DistGen->new( dir => $tmp ); +$dist->regen; + +$dist->chdir_in; + + +use Config; +use File::Spec::Functions qw( catdir splitdir splitpath ); + +######################### + +# We need to create a well defined environment to test install paths. +# We do this by setting up appropriate Config entries. + +my @installstyle = qw(lib perl5); +my $mb = Module::Build->new_from_context( + installdirs => 'site', + config => { + installstyle => catdir(@installstyle), + + installprivlib => catdir($tmp, @installstyle), + installarchlib => catdir($tmp, @installstyle, + @Config{qw(version archname)}), + installbin => catdir($tmp, 'bin'), + installscript => catdir($tmp, 'bin'), + installman1dir => catdir($tmp, 'man', 'man1'), + installman3dir => catdir($tmp, 'man', 'man3'), + installhtml1dir => catdir($tmp, 'html'), + installhtml3dir => catdir($tmp, 'html'), + + installsitelib => catdir($tmp, 'site', @installstyle, 'site_perl'), + installsitearch => catdir($tmp, 'site', @installstyle, 'site_perl', + @Config{qw(version archname)}), + installsitebin => catdir($tmp, 'site', 'bin'), + installsitescript => catdir($tmp, 'site', 'bin'), + installsiteman1dir => catdir($tmp, 'site', 'man', 'man1'), + installsiteman3dir => catdir($tmp, 'site', 'man', 'man3'), + installsitehtml1dir => catdir($tmp, 'site', 'html'), + installsitehtml3dir => catdir($tmp, 'site', 'html'), + } +); +isa_ok( $mb, 'Module::Build::Base' ); + +# Get us into a known state. +$mb->install_base(undef); +$mb->prefix(undef); + + +# Check install_path() accessor +{ + my( $map, $path ); + + $map = $mb->install_path(); + is_deeply( $map, {}, 'install_path() accessor' ); + + $path = $mb->install_path('elem' => '/foo/bar'); + is( $path, '/foo/bar', ' returns assigned path' ); + + $path = $mb->install_path('elem'); + is( $path, '/foo/bar', ' can read stored path' ); + + $map = $mb->install_path(); + is_deeply( $map, { 'elem' => '/foo/bar' }, ' can access map' ); + + $path = $mb->install_path('elem' => undef); + is( $path, undef, ' can delete a path element' ); + + $map = $mb->install_path(); + is_deeply( $map, {}, ' deletes path from map' ); +} + +# Check install_base_relpaths() accessor +{ + my( $map, $path ); + + $map = $mb->install_base_relpaths(); + is( ref($map), 'HASH', 'install_base_relpaths() accessor' ); + + eval{ $path = $mb->install_base_relpaths('elem' => '/foo/bar') }; + like( $@, qr/Value must be a relative path/, ' emits error if path not relative' ); + + $path = $mb->install_base_relpaths('elem' => 'foo/bar'); + is( $path, catdir(qw(foo bar)), ' returns assigned path' ); + + $path = $mb->install_base_relpaths('elem'); + is( $path, catdir(qw(foo/bar)), ' can read stored path' ); + + $map = $mb->install_base_relpaths(); + is_deeply( $map->{elem}, [qw(foo bar)], ' can access map' ); + + $path = $mb->install_base_relpaths('elem' => undef); + is( $path, undef, ' can delete a path element' ); + + $map = $mb->install_base_relpaths(); + is( $map->{elem}, undef, ' deletes path from map' ); +} + +# Check prefix_relpaths() accessor +{ + my( $map, $path ); + + $map = $mb->prefix_relpaths(); + is( ref($map), 'HASH', 'prefix_relpaths() accessor' ); + + is_deeply( $mb->prefix_relpaths(), $mb->prefix_relpaths('site'), + ' defaults to \'site\'' ); + + eval{ $path = $mb->prefix_relpaths('site', 'elem' => '/foo/bar') }; + like( $@, qr/Value must be a relative path/, ' emits error if path not relative' ); + + $path = $mb->prefix_relpaths('site', 'elem' => 'foo/bar'); + is( $path, catdir(qw(foo bar)), ' returns assigned path' ); + + $path = $mb->prefix_relpaths('site', 'elem'); + is( $path, catdir(qw(foo bar)), ' can read stored path' ); + + $map = $mb->prefix_relpaths(); + is_deeply( $map->{elem}, [qw(foo bar)], ' can access map' ); + + $path = $mb->prefix_relpaths('site', 'elem' => undef); + is( $path, undef, ' can delete a path element' ); + + $map = $mb->prefix_relpaths(); + is( $map->{elem}, undef, ' deletes path from map' ); +} + + +# Check that we install into the proper default locations. +{ + is( $mb->installdirs, 'site' ); + is( $mb->install_base, undef ); + is( $mb->prefix, undef ); + + test_install_destinations( $mb, { + lib => catdir($tmp, 'site', @installstyle, 'site_perl'), + arch => catdir($tmp, 'site', @installstyle, 'site_perl', + @Config{qw(version archname)}), + bin => catdir($tmp, 'site', 'bin'), + script => catdir($tmp, 'site', 'bin'), + bindoc => catdir($tmp, 'site', 'man', 'man1'), + libdoc => catdir($tmp, 'site', 'man', 'man3'), + binhtml => catdir($tmp, 'site', 'html'), + libhtml => catdir($tmp, 'site', 'html'), + }); +} + + +# Is installdirs honored? +{ + $mb->installdirs('core'); + is( $mb->installdirs, 'core' ); + + test_install_destinations( $mb, { + lib => catdir($tmp, @installstyle), + arch => catdir($tmp, @installstyle, @Config{qw(version archname)}), + bin => catdir($tmp, 'bin'), + script => catdir($tmp, 'bin'), + bindoc => catdir($tmp, 'man', 'man1'), + libdoc => catdir($tmp, 'man', 'man3'), + binhtml => catdir($tmp, 'html'), + libhtml => catdir($tmp, 'html'), + }); + + $mb->installdirs('site'); + is( $mb->installdirs, 'site' ); +} + + +# Check install_base() +{ + my $install_base = catdir( 'foo', 'bar' ); + $mb->install_base( $install_base ); + + is( $mb->prefix, undef ); + is( $mb->install_base, $install_base ); + + + test_install_destinations( $mb, { + lib => catdir( $install_base, 'lib', 'perl5' ), + arch => catdir( $install_base, 'lib', 'perl5', $Config{archname} ), + bin => catdir( $install_base, 'bin' ), + script => catdir( $install_base, 'bin' ), + bindoc => catdir( $install_base, 'man', 'man1'), + libdoc => catdir( $install_base, 'man', 'man3' ), + binhtml => catdir( $install_base, 'html' ), + libhtml => catdir( $install_base, 'html' ), + }); +} + + +# Basic prefix test. Ensure everything is under the prefix. +{ + $mb->install_base( undef ); + ok( !defined $mb->install_base ); + + my $prefix = catdir( qw( some prefix ) ); + $mb->prefix( $prefix ); + is( $mb->{properties}{prefix}, $prefix ); + + test_prefix($prefix, $mb->install_sets('site')); +} + + +# And now that prefix honors installdirs. +{ + $mb->installdirs('core'); + is( $mb->installdirs, 'core' ); + + my $prefix = catdir( qw( some prefix ) ); + test_prefix($prefix); + + $mb->installdirs('site'); + is( $mb->installdirs, 'site' ); +} + + +# Try a config setting which would result in installation locations outside +# the prefix. Ensure it doesn't. +{ + # Get the prefix defaults + my $defaults = $mb->prefix_relpaths('site'); + + # Create a configuration involving weird paths that are outside of + # the configured prefix. + my @prefixes = ( + [qw(foo bar)], + [qw(biz)], + [], + ); + + my %test_config; + foreach my $type (keys %$defaults) { + my $prefix = shift @prefixes || [qw(foo bar)]; + $test_config{$type} = catdir(File::Spec->rootdir, @$prefix, + @{$defaults->{$type}}); + } + + # Poke at the innards of MB to change the default install locations. + my $old = $mb->install_sets->{site}; + $mb->install_sets->{site} = \%test_config; + $mb->config(siteprefixexp => catdir(File::Spec->rootdir, + 'wierd', 'prefix')); + + my $prefix = catdir('another', 'prefix'); + $mb->prefix($prefix); + test_prefix($prefix, \%test_config); + $mb->install_sets->{site} = $old; +} + + +# Check that we can use install_base after setting prefix. +{ + my $install_base = catdir( 'foo', 'bar' ); + $mb->install_base( $install_base ); + + test_install_destinations( $mb, { + lib => catdir( $install_base, 'lib', 'perl5' ), + arch => catdir( $install_base, 'lib', 'perl5', $Config{archname} ), + bin => catdir( $install_base, 'bin' ), + script => catdir( $install_base, 'bin' ), + bindoc => catdir( $install_base, 'man', 'man1'), + libdoc => catdir( $install_base, 'man', 'man3' ), + binhtml => catdir( $install_base, 'html' ), + libhtml => catdir( $install_base, 'html' ), + }); +} + + +sub test_prefix { + my ($prefix, $test_config) = @_; + + local $Test::Builder::Level = $Test::Builder::Level + 1; + + foreach my $type (qw(lib arch bin script bindoc libdoc binhtml libhtml)) { + my $dest = $mb->install_destination( $type ); + ok $mb->dir_contains($prefix, $dest), "$type prefixed"; + + SKIP: { + skip( "'$type' not configured", 1 ) + unless $test_config && $test_config->{$type}; + + have_same_ending( $dest, $test_config->{$type}, + " suffix correctish " . + "($test_config->{$type} + $prefix = $dest)" ); + } + } +} + +sub have_same_ending { + my ($dir1, $dir2, $message) = @_; + + $dir1 =~ s{/$}{} if $^O eq 'cygwin'; # remove any trailing slash + my (undef, $dirs1, undef) = splitpath $dir1; + my @dir1 = splitdir $dirs1; + + $dir2 =~ s{/$}{} if $^O eq 'cygwin'; # remove any trailing slash + my (undef, $dirs2, undef) = splitpath $dir2; + my @dir2 = splitdir $dirs2; + + is $dir1[-1], $dir2[-1], $message; +} + +sub test_install_destinations { + my($build, $expect) = @_; + + local $Test::Builder::Level = $Test::Builder::Level + 1; + + while( my($type, $expect) = each %$expect ) { + is( $build->install_destination($type), $expect, "$type destination" ); + } +} + @@ -0,0 +1,161 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest; + +my @unix_splits = + ( + { q{one t'wo th'ree f"o\"ur " "five" } => [ 'one', 'two three', 'fo"ur ', 'five' ] }, + { q{ foo bar } => [ 'foo', 'bar' ] }, + { q{ D\'oh f\{g\'h\"i\]\* } => [ "D'oh", "f{g'h\"i]*" ] }, + { q{ D\$foo } => [ 'D$foo' ] }, + { qq{one\\\ntwo} => [ "one\ntwo" ] }, # TODO + ); + +my @win_splits = + ( + { 'a" "b\\c" "d' => [ 'a b\c d' ] }, + { '"a b\\c d"' => [ 'a b\c d' ] }, + { '"a b"\\"c d"' => [ 'a b"c', 'd' ] }, + { '"a b"\\\\"c d"' => [ 'a b\c d' ] }, + { '"a"\\"b" "a\\"b"' => [ 'a"b a"b' ] }, + { '"a"\\\\"b" "a\\\\"b"' => [ 'a\b', 'a\b' ] }, + { '"a"\\"b a\\"b"' => [ 'a"b', 'a"b' ] }, + { 'a"\\"b" "a\\"b' => [ 'a"b', 'a"b' ] }, + { 'a"\\"b" "a\\"b' => [ 'a"b', 'a"b' ] }, + { 'a b' => [ 'a', 'b' ] }, + { 'a"\\"b a\\"b' => [ 'a"b a"b' ] }, + { '"a""b" "a"b"' => [ 'a"b ab' ] }, + { '\\"a\\"' => [ '"a"' ] }, + { '"a"" "b"' => [ 'a"', 'b' ] }, + { 'a"b' => [ 'ab' ] }, + { 'a""b' => [ 'ab' ] }, + { 'a"""b' => [ 'a"b' ] }, + { 'a""""b' => [ 'a"b' ] }, + { 'a"""""b' => [ 'a"b' ] }, + { 'a""""""b' => [ 'a""b' ] }, + { '"a"b"' => [ 'ab' ] }, + { '"a""b"' => [ 'a"b' ] }, + { '"a"""b"' => [ 'a"b' ] }, + { '"a""""b"' => [ 'a"b' ] }, + { '"a"""""b"' => [ 'a""b' ] }, + { '"a""""""b"' => [ 'a""b' ] }, + { '' => [ ] }, + { ' ' => [ ] }, + { '""' => [ '' ] }, + { '" "' => [ ' ' ] }, + { '""a' => [ 'a' ] }, + { '""a b' => [ 'a', 'b' ] }, + { 'a""' => [ 'a' ] }, + { 'a"" b' => [ 'a', 'b' ] }, + { '"" a' => [ '', 'a' ] }, + { 'a ""' => [ 'a', '' ] }, + { 'a "" b' => [ 'a', '', 'b' ] }, + { 'a " " b' => [ 'a', ' ', 'b' ] }, + { 'a " b " c' => [ 'a', ' b ', 'c' ] }, +); + +plan tests => 9 + 4*@unix_splits + 4*@win_splits; + +blib_load('Module::Build'); +blib_load('Module::Build::Platform::Unix'); +blib_load('Module::Build::Platform::Windows'); + +######################### + +# Should always return an array unscathed +foreach my $platform ('', '::Platform::Unix', '::Platform::Windows') { + my $pkg = "Module::Build$platform"; + my @result = $pkg->split_like_shell(['foo', 'bar', 'baz']); + is @result, 3, "Split using $pkg"; + is "@result", "foo bar baz", "Split using $pkg"; +} + +# I think 3.24 isn't actually the majik version, my 3.23 seems to pass... +my $low_TPW_version = Text::ParseWords->VERSION < 3.24; +foreach my $test (@unix_splits) { + # Text::ParseWords bug: + local $TODO = $low_TPW_version && ((keys %$test)[0] =~ m{\\\n}); + + do_split_tests('Module::Build::Platform::Unix', $test); +} + +foreach my $test (@win_splits) { + do_split_tests('Module::Build::Platform::Windows', $test); +} + + +{ + # Make sure read_args() functions properly as a class method + my @args = qw(foo=bar --food bard --foods=bards); + my ($args) = Module::Build->read_args(@args); + is_deeply($args, {foo => 'bar', food => 'bard', foods => 'bards', ARGV => []}); +} + +{ + # Make sure data can make a round-trip through unparse_args() and read_args() + my %args = (foo => 'bar', food => 'bard', config => {a => 1, b => 2}, ARGV => []); + my ($args) = Module::Build->read_args( Module::Build->unparse_args(\%args) ); + is_deeply($args, \%args); +} + +{ + # Make sure data can make a round-trip through an external perl + # process, which can involve the shell command line + + # silence the printing for easier matching + local *Module::Build::log_info = sub {}; + + my @data = map values(%$_), @unix_splits, @win_splits; + for my $d (@data) { + my $out = stdout_of + ( sub { + Module::Build->run_perl_script('-le', [], ['print join " ", map "{$_}", @ARGV', @$d]); + } ); + chomp $out; + is($out, join(' ', map "{$_}", @$d), "perl round trip for ".join('',map "{$_}", @$d)); + } +} + +{ + # Make sure data can make a round-trip through an external backtick + # process, which can involve the shell command line + + # silence the printing for easier matching + local *Module::Build::log_info = sub {}; + + my @data = map values(%$_), @unix_splits, @win_splits; + for my $d (@data) { + chomp(my $out = Module::Build->_backticks($^X, '-le', 'print join " ", map "{$_}", @ARGV', @$d)); + is($out, join(' ', map "{$_}", @$d), "backticks round trip for ".join('',map "{$_}", @$d)); + } +} + +{ + # Make sure run_perl_script() propagates @INC + my $dir = MBTest->tmpdir; + if ($^O eq 'VMS') { + # VMS can store INC paths in Unix format with out the trailing + # directory delimiter. + $dir = VMS::Filespec::unixify($dir); + $dir =~ s#/$##; + } + local @INC = ($dir, @INC); + my $output = stdout_of( sub { Module::Build->run_perl_script('-le', [], ['print for @INC']) } ); + like $output, qr{^\Q$dir\E}m; +} + +################################################################## +sub do_split_tests { + my ($package, $test) = @_; + + my ($string, $expected) = %$test; + my @result = $package->split_like_shell($string); + is( 0 + grep( !defined(), @result ), # all defined + 0, + "'$string' result all defined" ); + is_deeply(\@result, $expected) or + diag("$package split_like_shell error \n" . + ">$string< is not splitting as >" . join("|", @$expected) . '<'); +} diff --git a/t/extend.t b/t/extend.t new file mode 100644 index 0000000..ae30f8d --- /dev/null +++ b/t/extend.t @@ -0,0 +1,281 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest tests => 63; + +blib_load('Module::Build'); + +my $tmp = MBTest->tmpdir; + +use DistGen; +my $dist = DistGen->new( dir => $tmp ); +$dist->regen; + +$dist->chdir_in; + +######################### + +# 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; + my $t_basic_t = File::Spec->catfile('t', 'basic.t'); + $t_basic_t = VMS::Filespec::vmsify($t_basic_t) if $^O eq 'VMS'; + ok grep {$_ eq $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 share_dir 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 => {keywords => ['bar']}, + conflicts => {'Foo::Barxx' => 0}, + ); + my $data = $mb->get_metadata; + is_deeply $data->{keywords}, ['bar']; + + $mb->meta_merge(keywords => ['baz']); + $data = $mb->get_metadata; + is_deeply $data->{keywords}, [qw/bar baz/]; + + $mb->meta_merge( + 'meta-spec' => { version => 2 }, + prereqs => { + test => { + requires => { + 'Foo::Fooxx' => 0, + } + } + } + ); + $data = $mb->get_metadata; + is_deeply $data->{prereqs}{test}{requires}, { 'Foo::Fooxx' => 0 } or diag explain $mb->meta_merge; + +} + +{ + # 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 <enter> 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 <enter> 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 <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"; + + my @ans = $mb->prompt("Is this a question", undef); + is_deeply([@ans], [undef], " prompt() with undef() default"); + } + +} + diff --git a/t/files.t b/t/files.t new file mode 100644 index 0000000..e951b80 --- /dev/null +++ b/t/files.t @@ -0,0 +1,46 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest tests => 4; + +blib_load('Module::Build'); + +my $tmp = MBTest->tmpdir; + +use DistGen; +my $dist = DistGen->new( dir => $tmp ); +$dist->regen; + +$dist->chdir_in; + +my $mb = Module::Build->new_from_context; + +{ + # Make sure copy_if_modified() can handle spaces in filenames + + my @tmp; + push @tmp, MBTest->tmpdir for (0 .. 1); + + my $filename = 'file with spaces.txt'; + + my $file = File::Spec->catfile($tmp[0], $filename); + open(my $fh, '>', $file) or die "Can't create $file: $!"; + print $fh "Foo\n"; + close $fh; + ok -e $file; + + + my $file2 = $mb->copy_if_modified(from => $file, to_dir => $tmp[1]); + ok $file2; + ok -e $file2; +} + +{ + # Try some dir_contains() combinations + my $first = File::Spec->catdir('', 'one', 'two'); + my $second = File::Spec->catdir('', 'one', 'two', 'three'); + + ok( Module::Build->dir_contains($first, $second) ); +} + diff --git a/t/help.t b/t/help.t new file mode 100644 index 0000000..0534c92 --- /dev/null +++ b/t/help.t @@ -0,0 +1,263 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest tests => 23; + +blib_load('Module::Build'); + +use DistGen; + +my $dist = DistGen->new; +$dist->regen; +$dist->chdir_in; + +my $restart = sub { + # we're redefining the same package as we go, so... + delete($::{'MyModuleBuilder::'}); + delete($INC{'MyModuleBuilder.pm'}); + $dist->regen( clean => 1 ); +}; + +######################################################################## +{ # check the =item style +my $mb = Module::Build->subclass( + code => join "\n", map {s/^ {4}//; $_} split /\n/, <<' ---', + =head1 ACTIONS + + =over + + =item foo + + Does the foo thing. + + =item bar + + Does the bar thing. + + =item help + + Does the help thing. + + You should probably not be seeing this. That is, we haven't + overridden the help action, but we're able to override just the + docs? That almost seems reasonable, but is probably wrong. + + =back + + =cut + + sub ACTION_foo { die "fooey" } + sub ACTION_bar { die "barey" } + sub ACTION_baz { die "bazey" } + + # guess we can have extra pod later + + =over + + =item baz + + Does the baz thing. + + =back + + =cut + + --- + )->new( + module_name => $dist->name, + ); + +ok $mb; +can_ok($mb, 'ACTION_foo'); + +foreach my $action (qw(foo bar baz)) { # typical usage + my $doc = $mb->get_action_docs($action); + ok($doc, "got doc for '$action'"); + like($doc, qr/^=\w+ $action\n\nDoes the $action thing\./s, + 'got the right doc'); +} + +{ # user typo'd the action name + ok( ! eval {$mb->get_action_docs('batz'); 1}, 'slap'); + like($@, qr/No known action 'batz'/, 'informative error'); +} + +{ # XXX this one needs some thought + my $action = 'help'; + my $doc = $mb->get_action_docs($action); + ok($doc, "got doc for '$action'"); + 0 and warn "help doc >\n$doc<\n"; + TODO: { + local $TODO = 'Do we allow overrides on just docs?'; + unlike($doc, qr/^=\w+ $action\n\nDoes the $action thing\./s, + 'got the right doc'); + } +} +} # end =item style +$restart->(); +######################################################################## +if(0) { # the =item style without spanning =head1 sections +my $mb = Module::Build->subclass( + code => join "\n", map {s/^ {4}//; $_} split /\n/, <<' ---', + =head1 ACTIONS + + =over + + =item foo + + Does the foo thing. + + =item bar + + Does the bar thing. + + =back + + =head1 thbbt + + =over + + =item baz + + Should not see this. + + =back + + =cut + + sub ACTION_foo { die "fooey" } + sub ACTION_bar { die "barey" } + sub ACTION_baz { die "bazey" } + + --- + )->new( + module_name => $dist->name, + ); + +ok $mb; +can_ok($mb, 'ACTION_foo'); + +foreach my $action (qw(foo bar)) { # typical usage + my $doc = $mb->get_action_docs($action); + ok($doc, "got doc for '$action'"); + like($doc, qr/^=\w+ $action\n\nDoes the $action thing\./s, + 'got the right doc'); +} +is($mb->get_action_docs('baz'), undef, 'no jumping =head1 sections'); + +} # end =item style without spanning =head1's +$restart->(); +######################################################################## +TODO: { # the =item style with 'Actions' not 'ACTIONS' +local $TODO = 'Support capitalized Actions section'; +my $mb = Module::Build->subclass( + code => join "\n", map {s/^ {4}//; $_} split /\n/, <<' ---', + =head1 Actions + + =over + + =item foo + + Does the foo thing. + + =item bar + + Does the bar thing. + + =back + + =cut + + sub ACTION_foo { die "fooey" } + sub ACTION_bar { die "barey" } + + --- + )->new( + module_name => $dist->name, + ); + +foreach my $action (qw(foo bar)) { # typical usage + my $doc = $mb->get_action_docs($action); + ok($doc, "got doc for '$action'"); + like($doc || 'undef', qr/^=\w+ $action\n\nDoes the $action thing\./s, + 'got the right doc'); +} + +} # end =item style with Actions +$restart->(); +######################################################################## +{ # check the =head2 style +my $mb = Module::Build->subclass( + code => join "\n", map {s/^ {4}//; $_} split /\n/, <<' ---', + =head1 ACTIONS + + =head2 foo + + Does the foo thing. + + =head2 bar + + Does the bar thing. + + =head3 bears + + Be careful with bears. + + =cut + + sub ACTION_foo { die "fooey" } + sub ACTION_bar { die "barey" } + sub ACTION_baz { die "bazey" } + sub ACTION_batz { die "batzey" } + + # guess we can have extra pod later + # Though, I do wonder whether we should allow them to mix... + # maybe everything should have to be head2? + + =head2 baz + + Does the baz thing. + + =head4 What's a baz? + + =head1 not this part + + This is level 1, so the stuff about baz is done. + + =head1 Thing + + =head2 batz + + This is not an action doc. + + =cut + + --- + )->new( + module_name => $dist->name, + ); + +my %also = ( + foo => '', + bar => "\n=head3 bears\n\nBe careful with bears.\n", + baz => "\n=head4 What's a baz\\?\n", +); + +foreach my $action (qw(foo bar baz)) { + my $doc = $mb->get_action_docs($action); + ok($doc, "got doc for '$action'"); + my $and = $also{$action}; + like($doc || 'undef', + qr/^=\w+ $action\n\nDoes the $action thing\.\n$and\n$/s, + 'got the right doc'); +} +is($mb->get_action_docs('batz'), undef, 'nothing after uplevel'); + +} # end =head2 style +######################################################################## + +# cleanup +$dist->clean(); + +# vim:ts=2:sw=2:et:sta diff --git a/t/install.t b/t/install.t new file mode 100644 index 0000000..fde3958 --- /dev/null +++ b/t/install.t @@ -0,0 +1,230 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest tests => 34; + +blib_load('Module::Build'); + +use Config; +use Cwd (); +my $cwd = Cwd::cwd; +my $tmp = MBTest->tmpdir; + +use DistGen; +my $dist = DistGen->new( dir => $tmp ); +$dist->regen; +$dist->chdir_in; + +######################### + + +$dist->add_file( 'script', <<'---' ); +#!perl -w +print "Hello, World!\n"; +--- +$dist->change_build_pl +({ + module_name => $dist->name, + scripts => [ 'script' ], + license => 'perl', + requires => { 'File::Spec' => 0 }, +}); +$dist->regen; + + +use File::Spec::Functions qw( catdir ); + +my $mb = Module::Build->new_from_context( + # Need default install paths to ensure manpages get generated. + installdirs => 'site', + config => { + installman1dir => catdir($tmp, 'man', 'man1'), + installman3dir => catdir($tmp, 'man', 'man3'), + installsiteman1dir => catdir($tmp, 'site', 'man', 'man1'), + installsiteman3dir => catdir($tmp, 'site', 'man', 'man3'), + ## We also used to have HTML paths here, but building HTML docs + ## can be super slow, and we never checked the result anyway. + } + +); + +ok $mb; + + +my $destdir = File::Spec->catdir($cwd, 't', 'install_test' . $$); +$mb->add_to_cleanup($destdir); + +{ + eval {$mb->dispatch('install', destdir => $destdir)}; + is $@, ''; + + my @libdir = strip_volume( $mb->install_destination('lib') ); + my $install_to = File::Spec->catfile($destdir, @libdir, $dist->name ) . '.pm'; + file_exists($install_to); + + local @INC = (@INC, File::Spec->catdir($destdir, @libdir)); + eval "require @{[$dist->name]}"; + is $@, ''; + + # Make sure there's a packlist installed + my $archdir = $mb->install_destination('arch'); + my @dirs = strip_volume($archdir); + my $packlist = File::Spec->catfile + ($destdir, @dirs, 'auto', $dist->name, '.packlist'); + is -e $packlist, 1, "$packlist should be written"; +} + +{ + eval {$mb->dispatch('install', installdirs => 'core', destdir => $destdir)}; + is $@, ''; + my @libdir = strip_volume( $Config{installprivlib} ); + my $install_to = File::Spec->catfile($destdir, @libdir, $dist->name ) . '.pm'; + file_exists($install_to); +} + +{ + my $libdir = File::Spec->catdir(File::Spec->rootdir, 'foo', 'bar'); + eval {$mb->dispatch('install', install_path => {lib => $libdir}, destdir => $destdir)}; + is $@, ''; + my @dirs = strip_volume($libdir); + my $install_to = File::Spec->catfile($destdir, @dirs, $dist->name ) . '.pm'; + file_exists($install_to); +} + +{ + my $libdir = File::Spec->catdir(File::Spec->rootdir, 'foo', 'base'); + eval {$mb->dispatch('install', install_base => $libdir, destdir => $destdir)}; + is $@, ''; + my @dirs = strip_volume($libdir); + my $install_to = File::Spec->catfile($destdir, @dirs, 'lib', 'perl5', $dist->name ) . '.pm'; + file_exists($install_to); +} + +{ + # Test the ConfigData stuff + + $mb->config_data(foo => 'bar'); + $mb->features(baz => 1); + $mb->auto_features(auto_foo => {requires => {'File::Spec' => 0}}); + eval {$mb->dispatch('install', destdir => $destdir)}; + is $@, ''; + + my @libdir = strip_volume( $mb->install_destination('lib') ); + local @INC = (@INC, File::Spec->catdir($destdir, @libdir)); + eval "require @{[$dist->name]}::ConfigData"; + + is $mb->feature('auto_foo'), 1; + + SKIP: { + skip $@, 5 if @_; + + # Make sure the values are present + my $config = $dist->name . '::ConfigData'; + is( $config->config('foo'), 'bar' ); + ok( $config->feature('baz') ); + ok( $config->feature('auto_foo') ); + ok( not $config->feature('nonexistent') ); + + # Add a new value to the config set + $config->set_config(floo => 'bhlar'); + is( $config->config('floo'), 'bhlar' ); + + # Make sure it actually got written + $config->write; + delete $INC{"@{[$dist->name]}/ConfigData.pm"}; + { + local $^W; # Avoid warnings for subroutine redefinitions + eval "require $config"; + } + is( $config->config('floo'), 'bhlar' ); + } +} + + +eval {$mb->dispatch('realclean')}; +is $@, ''; + +{ + # Try again by running the script rather than with programmatic interface + my $libdir = File::Spec->catdir('', 'foo', 'lib'); + eval {$mb->run_perl_script('Build.PL', [], ['--install_path', "lib=$libdir"])}; + is $@, ''; + + my $cmd = 'Build'; + $cmd .= ".COM" if $^O eq 'VMS'; + eval {$mb->run_perl_script($cmd, [], ['install', '--destdir', $destdir])}; + is $@, ''; + my $install_to = File::Spec->catfile($destdir, $libdir, $dist->name ) . '.pm'; + file_exists($install_to); + + my $basedir = File::Spec->catdir('', 'bar'); + eval {$mb->run_perl_script($cmd, [], ['install', '--destdir', $destdir, + '--install_base', $basedir])}; + is $@, ''; + + $install_to = File::Spec->catfile($destdir, $libdir, $dist->name ) . '.pm'; + is -e $install_to, 1, "Look for file at $install_to"; + + eval {$mb->dispatch('realclean')}; + is $@, ''; +} + +{ + # Make sure 'install_path' overrides 'install_base' + my $mb = Module::Build->new( module_name => $dist->name, + install_base => File::Spec->catdir('', 'foo'), + install_path => { + lib => File::Spec->catdir('', 'bar') + } + ); + ok $mb; + is $mb->install_destination('lib'), File::Spec->catdir('', 'bar'); +} + +{ + $dist->add_file( 'lib/Simple/Docs.pod', <<'---' ); +=head1 NAME + +Simple::Docs - Simple pod + +=head1 AUTHOR + +Simple Man <simple@example.com> + +=cut +--- + $dist->regen; + + # _find_file_by_type() isn't a public method, but this is currently + # the only easy way to test that it works properly. + my $pods = $mb->_find_file_by_type('pod', 'lib'); + is keys %$pods, 1; + my $expect = $mb->localize_file_path('lib/Simple/Docs.pod'); + + is $pods->{$expect}, $expect; + + my $pms = $mb->_find_file_by_type('awefawef', 'lib'); + ok $pms; + is keys %$pms, 0; + + $pms = $mb->_find_file_by_type('pod', 'awefawef'); + ok $pms; + is keys %$pms, 0; + + # revert to pristine state + $dist->regen( clean => 1 ); +} + +sub strip_volume { + my $dir = shift; + (undef, $dir) = File::Spec->splitpath( $dir, 1 ); + my @dirs = File::Spec->splitdir($dir); + return @dirs; +} + +sub file_exists { + my $file = shift; + ok -e $file or diag("Expected $file to exist, but it doesn't"); +} + diff --git a/t/install_extra_target.t b/t/install_extra_target.t new file mode 100644 index 0000000..09d2cbe --- /dev/null +++ b/t/install_extra_target.t @@ -0,0 +1,135 @@ +#!perl -w +# Contributed by: Thorben Jaendling + +use strict; +use lib 't/lib'; +use MBTest tests => 6; + +blib_load('Module::Build'); + +use File::Spec::Functions qw( catdir catfile ); + +my $tmp = MBTest->tmpdir; +my $output; + +use DistGen; +my $dist = DistGen->new( dir => $tmp ); + +# note("Dist is in $tmp\n"); + +$dist->add_file("Build.PL", <<'===EOF==='); +#!perl -w + +use strict; +use Module::Build; + +my $subclass = Module::Build->subclass(code => <<'=EOF='); +sub copy_files +{ + my $self = shift; + my $dir = shift; + + my $files = $self->rscan_dir($dir, sub {-f $_ and not m!/\.|[#~]$!}); + + foreach my $file (@$files) { + $self->copy_if_modified(from => $file, to_dir => "blib"); + } +} + +#Copy etc files to blib +sub process_etc_files +{ + my $self = shift; + + $self->copy_files("etc"); +} + +#Copy share files to blib +sub process_shared_files +{ + my $self = shift; + + $self->copy_files("shared"); +} + +1; +=EOF= + +my $build = $subclass->new( + module_name => 'Simple', + license => 'perl' +); + +$build->add_build_element('etc'); +$build->add_build_element('shared'); + +my $distdir = lc $build->dist_name(); + +foreach my $id ('core', 'site', 'vendor') { + #Where to install these build types when using prefix symantics + $build->prefix_relpaths($id, 'shared' => "shared/$distdir"); + $build->prefix_relpaths($id, 'etc' => "etc/$distdir"); + + #Where to install these build types when using default symantics + my $set = $build->install_sets($id); + $set->{'shared'} = '/usr/'.($id eq 'site' ? 'local/':'')."shared/$distdir"; + $set->{'etc'} = ($id eq 'site' ? '/usr/local/etc/':'/etc/').$distdir; +} + +#Where to install these types when using install_base symantics +$build->install_base_relpaths('shared' => "shared/$distdir"); +$build->install_base_relpaths('etc' => "etc/$distdir"); + +$build->create_build_script(); + +===EOF=== + +#Test Build.PL exists ok? + +$dist->add_file("etc/config", <<'===EOF==='); +[main] +Foo = bar +Jim = bob + +[supplemental] +stardate = 1234344 + +===EOF=== + +$dist->add_file("shared/data", <<'===EOF==='); +7 * 9 = 42? + +===EOF=== + +$dist->add_file("shared/html/index.html", <<'===EOF==='); +<HTML> + <BODY> + <H1>Hello World!</H1> + </BODY> +</HTML> + +===EOF=== + +$dist->regen; +$dist->chdir_in; + +my $installdest = catdir($tmp, 't', "install_extra_targets-$$"); + +$output = stdout_of sub { $dist->run_build_pl("--install_base=$installdest") }; + +$output .= stdout_of sub { $dist->run_build }; + +my $error; +$error++ unless ok(-e "blib/etc/config", "Built etc/config"); +$error++ unless ok(-e "blib/shared/data", "Built shared/data"); +$error++ unless ok(-e "blib/shared/html/index.html", "Built shared/html"); +diag "OUTPUT:\n$output" if $error; + +$output = stdout_of sub { $dist->run_build('install') }; + +$error = 0; +$error++ unless ok(-e catfile($installdest, qw/etc simple config/), "installed etc/config"); +$error++ unless ok(-e catfile($installdest, qw/shared simple data/), "installed shared/data"); +$error++ unless ok(-e catfile($installdest, qw/shared simple html index.html/), "installed shared/html"); +diag "OUTPUT:\n$output" if $error; + diff --git a/t/lib/DistGen.pm b/t/lib/DistGen.pm new file mode 100644 index 0000000..5249372 --- /dev/null +++ b/t/lib/DistGen.pm @@ -0,0 +1,859 @@ +package DistGen; + +use strict; + +use vars qw( $VERSION $VERBOSE @EXPORT_OK); + +$VERSION = '0.01'; +$VERBOSE = 0; + +use Carp; + +use MBTest (); +use Cwd (); +use File::Basename (); +use File::Find (); +use File::Path (); +use File::Spec (); +use Tie::CPHash; +use Data::Dumper; + +my $vms_mode; +my $vms_lower_case; + +BEGIN { + $vms_mode = 0; + $vms_lower_case = 0; + if( $^O eq 'VMS' ) { + # For things like vmsify() + require VMS::Filespec; + VMS::Filespec->import; + $vms_mode = 1; + $vms_lower_case = 1; + my $vms_efs_case = 0; + my $unix_rpt = 0; + if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { + $unix_rpt = VMS::Feature::current("filename_unix_report"); + $vms_efs_case = VMS::Feature::current("efs_case_preserve"); + } else { + my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; + $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; + my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || ''; + $vms_efs_case = $efs_case =~ /^[ET1]/i; + } + $vms_mode = 0 if $unix_rpt; + $vms_lower_case = 0 if $vms_efs_case; + } +} +BEGIN { + require Exporter; + *{import} = \&Exporter::import; + @EXPORT_OK = qw( + undent + ); +} + +sub undent { + my ($string) = @_; + + my ($space) = $string =~ m/^(\s+)/; + $string =~ s/^$space//gm; + + return($string); +} + +sub chdir_all ($) { + # OS/2 has "current directory per disk", undeletable; + # doing chdir() to another disk won't change cur-dir of initial disk... + chdir('/') if $^O eq 'os2'; + chdir shift; +} + +######################################################################## + +END { chdir_all(MBTest->original_cwd); } + +sub new { + my $self = bless {}, shift; + $self->reset(@_); +} + +sub reset { + my $self = shift; + my %options = @_; + + $options{name} ||= 'Simple'; + $options{version} ||= q{'0.01'}; + $options{license} ||= 'perl'; + $options{dir} = File::Spec->rel2abs( + defined $options{dir} ? $options{dir} : MBTest->tmpdir + ); + + my %data = ( + no_manifest => 0, + xs => 0, + inc => 0, + %options, + ); + %$self = %data; + + tie %{$self->{filedata}}, 'Tie::CPHash'; + + tie %{$self->{pending}{change}}, 'Tie::CPHash'; + + # start with a fresh, empty directory + if ( -d $self->dirname ) { + warn "Warning: Removing existing directory '@{[$self->dirname]}'\n"; + File::Path::rmtree( $self->dirname ); + } + File::Path::mkpath( $self->dirname ); + + $self->_gen_default_filedata(); + + return $self; +} + +sub remove { + my $self = shift; + $self->chdir_original if($self->did_chdir); + File::Path::rmtree( $self->dirname ); + return $self; +} + +sub revert { + my ($self, $file) = @_; + if ( defined $file ) { + delete $self->{filedata}{$file}; + delete $self->{pending}{$_}{$file} for qw/change remove/; + } + else { + delete $self->{filedata}{$_} for keys %{ $self->{filedata} }; + for my $pend ( qw/change remove/ ) { + delete $self->{pending}{$pend}{$_} for keys %{ $self->{pending}{$pend} }; + } + } + $self->_gen_default_filedata; +} + +sub _gen_default_filedata { + my $self = shift; + + # TODO maybe a public method like this (but with a better name?) + my $add_unless = sub { + my $self = shift; + my ($member, $data) = @_; + $self->add_file($member, $data) unless($self->{filedata}{$member}); + }; + + if ( ! $self->{inc} ) { + $self->$add_unless('Build.PL', undent(<<" ---")); + use strict; + use Module::Build; + + my \$builder = Module::Build->new( + module_name => '$self->{name}', + license => '$self->{license}', + ); + + \$builder->create_build_script(); + --- + } + else { + $self->$add_unless('Build.PL', undent(<<" ---")); + use strict; + use inc::latest 'Module::Build'; + + my \$builder = Module::Build->new( + module_name => '$self->{name}', + license => '$self->{license}', + ); + + \$builder->create_build_script(); + --- + } + + my $module_filename = + join( '/', ('lib', split(/::/, $self->{name})) ) . '.pm'; + + unless ( $self->{xs} ) { + $self->$add_unless($module_filename, undent(<<" ---")); + package $self->{name}; + + use vars qw( \$VERSION ); + \$VERSION = $self->{version}; + + use strict; + + 1; + + __END__ + + =head1 NAME + + $self->{name} - Perl extension for blah blah blah + + =head1 DESCRIPTION + + Stub documentation for $self->{name}. + + =head1 AUTHOR + + A. U. Thor, a.u.thor\@a.galaxy.far.far.away + + =cut + --- + + $self->$add_unless('t/basic.t', undent(<<" ---")); + use Test::More tests => 1; + use strict; + + use $self->{name}; + ok 1; + --- + + } else { + $self->$add_unless($module_filename, undent(<<" ---")); + package $self->{name}; + + \$VERSION = $self->{version}; + + require Exporter; + require DynaLoader; + + \@ISA = qw(Exporter DynaLoader); + \@EXPORT_OK = qw( okay ); + + bootstrap $self->{name} \$VERSION; + + 1; + + __END__ + + =head1 NAME + + $self->{name} - Perl extension for blah blah blah + + =head1 DESCRIPTION + + Stub documentation for $self->{name}. + + =head1 AUTHOR + + A. U. Thor, a.u.thor\@a.galaxy.far.far.away + + =cut + --- + + my $xs_filename = + join( '/', ('lib', split(/::/, $self->{name})) ) . '.xs'; + $self->$add_unless($xs_filename, undent(<<" ---")); + #include "EXTERN.h" + #include "perl.h" + #include "XSUB.h" + + MODULE = $self->{name} PACKAGE = $self->{name} + + SV * + okay() + CODE: + RETVAL = newSVpv( "ok", 0 ); + OUTPUT: + RETVAL + + const char * + xs_version() + CODE: + RETVAL = XS_VERSION; + OUTPUT: + RETVAL + + const char * + version() + CODE: + RETVAL = VERSION; + OUTPUT: + RETVAL + --- + + # 5.6 is missing const char * in its typemap + $self->$add_unless('typemap', undent(<<" ---")); + const char *\tT_PV + --- + + $self->$add_unless('t/basic.t', undent(<<" ---")); + use Test::More tests => 2; + use strict; + + use $self->{name}; + ok 1; + + ok( $self->{name}::okay() eq 'ok' ); + --- + } +} + +sub _gen_manifest { + my $self = shift; + my $manifest = shift; + + open(my $fh, '>', $manifest ) or do { + die "Can't write '$manifest'\n"; + }; + + my @files = ( 'MANIFEST', keys %{$self->{filedata}} ); + my $data = join( "\n", sort @files ) . "\n"; + print $fh $data; + close( $fh ); + + $self->{filedata}{MANIFEST} = $data; + $self->{pending}{change}{MANIFEST} = 1; +} + +sub name { shift()->{name} } + +sub dirname { + my $self = shift; + my $dist = $self->{distdir} || join( '-', split( /::/, $self->{name} ) ); + return File::Spec->catdir( $self->{dir}, $dist ); +} + +sub _real_filename { + my $self = shift; + my $filename = shift; + return File::Spec->catfile( split( /\//, $filename ) ); +} + +sub regen { + my $self = shift; + my %opts = @_; + + my $dist_dirname = $self->dirname; + + if ( $opts{clean} ) { + $self->clean() if -d $dist_dirname; + } else { + # TODO: This might leave dangling directories; e.g. if the removed file + # is 'lib/Simple/Simon.pm', the directory 'lib/Simple' will be left + # even if there are no files left in it. However, clean() will remove it. + my @files = keys %{$self->{pending}{remove}}; + foreach my $file ( @files ) { + my $real_filename = $self->_real_filename( $file ); + my $fullname = File::Spec->catfile( $dist_dirname, $real_filename ); + if ( -e $fullname ) { + 1 while unlink( $fullname ); + } + print "Unlinking pending file '$file'\n" if $VERBOSE; + delete( $self->{pending}{remove}{$file} ); + } + } + + foreach my $file ( keys( %{$self->{filedata}} ) ) { + my $real_filename = $self->_real_filename( $file ); + my $fullname = File::Spec->catfile( $dist_dirname, $real_filename ); + + if ( ! -e $fullname || + ( -e $fullname && $self->{pending}{change}{$file} ) ) { + + print "Changed file '$file'.\n" if $VERBOSE; + + my $dirname = File::Basename::dirname( $fullname ); + unless ( -d $dirname ) { + File::Path::mkpath( $dirname ) or do { + die "Can't create '$dirname'\n"; + }; + } + + if ( -e $fullname ) { + 1 while unlink( $fullname ); + } + + open(my $fh, '>', $fullname) or do { + die "Can't write '$fullname'\n"; + }; + print $fh $self->{filedata}{$file}; + close( $fh ); + } + + delete( $self->{pending}{change}{$file} ); + } + + my $manifest = File::Spec->catfile( $dist_dirname, 'MANIFEST' ); + unless ( $self->{no_manifest} ) { + if ( -e $manifest ) { + 1 while unlink( $manifest ); + } + $self->_gen_manifest( $manifest ); + } + return $self; +} + +sub clean { + my $self = shift; + + my $here = Cwd::abs_path(); + my $there = File::Spec->rel2abs( $self->dirname() ); + + if ( -d $there ) { + chdir( $there ) or die "Can't change directory to '$there'\n"; + } else { + die "Distribution not found in '$there'\n"; + } + + my %names; + tie %names, 'Tie::CPHash'; + foreach my $file ( keys %{$self->{filedata}} ) { + my $filename = $self->_real_filename( $file ); + $filename = lc($filename) if $vms_lower_case; + my $dirname = File::Basename::dirname( $filename ); + + $names{$filename} = 0; + + print "Splitting '$dirname'\n" if $VERBOSE; + my @dirs = File::Spec->splitdir( $dirname ); + while ( @dirs ) { + my $dir = ( scalar(@dirs) == 1 + ? $dirname + : File::Spec->catdir( @dirs ) ); + if (length $dir) { + print "Setting directory name '$dir' in \%names\n" if $VERBOSE; + $names{$dir} = 0; + } + pop( @dirs ); + } + } + + File::Find::finddepth( sub { + my $name = File::Spec->canonpath( $File::Find::name ); + + if ($vms_mode) { + if ($name ne '.') { + $name =~ s/\.\z//; + $name = vmspath($name) if -d $name; + } + } + if ($^O eq 'VMS') { + $name = File::Spec->rel2abs($name) if $name eq File::Spec->curdir(); + } + + if ( not exists $names{$name} ) { + print "Removing '$name'\n" if $VERBOSE; + File::Path::rmtree( $_ ); + } + }, ($^O eq 'VMS' ? './' : File::Spec->curdir) ); + + chdir_all( $here ); + return $self; +} + +sub add_file { + my $self = shift; + $self->change_file( @_ ); +} + +sub remove_file { + my $self = shift; + my $file = shift; + unless ( exists $self->{filedata}{$file} ) { + warn "Can't remove '$file': It does not exist.\n" if $VERBOSE; + } + delete( $self->{filedata}{$file} ); + $self->{pending}{remove}{$file} = 1; + return $self; +} + +sub change_build_pl { + my ($self, @opts) = @_; + + my $opts = ref $opts[0] eq 'HASH' ? $opts[0] : { @opts }; + + local $Data::Dumper::Terse = 1; + (my $args = Dumper($opts)) =~ s/^\s*\{|\}\s*$//g; + + $self->change_file( 'Build.PL', undent(<<" ---") ); + use strict; + use Module::Build; + my \$b = Module::Build->new( + # Some CPANPLUS::Dist::Build versions need to allow mismatches + # On logic: thanks to Module::Install, CPAN.pm must set both keys, but + # CPANPLUS sets only the one + allow_mb_mismatch => ( + \$ENV{PERL5_CPANPLUS_IS_RUNNING} && ! \$ENV{PERL5_CPAN_IS_RUNNING} ? 1 : 0 + ), + $args + ); + \$b->create_build_script(); + --- + return $self; +} + +sub change_file { + my $self = shift; + my $file = shift; + my $data = shift; + $self->{filedata}{$file} = $data; + $self->{pending}{change}{$file} = 1; + return $self; +} + +sub get_file { + my $self = shift; + my $file = shift; + exists($self->{filedata}{$file}) or croak("no such entry: '$file'"); + return $self->{filedata}{$file}; +} + +sub chdir_in { + my $self = shift; + $self->{original_dir} ||= Cwd::cwd; # only once! + my $dir = $self->dirname; + chdir($dir) or die "Can't chdir to '$dir': $!"; + return $self; +} +######################################################################## + +sub did_chdir { exists shift()->{original_dir} } + +######################################################################## + +sub chdir_original { + my $self = shift; + + my $dir = delete $self->{original_dir}; + chdir_all($dir) or die "Can't chdir to '$dir': $!"; + return $self; +} +######################################################################## + +sub new_from_context { + my ($self, @args) = @_; + require Module::Build; + return Module::Build->new_from_context( quiet => 1, @args ); +} + +sub run_build_pl { + my ($self, @args) = @_; + require Module::Build; + return Module::Build->run_perl_script('Build.PL', [], [@args]) +} + +sub run_build { + my ($self, @args) = @_; + require Module::Build; + my $build_script = $^O eq 'VMS' ? 'Build.com' : 'Build'; + return Module::Build->run_perl_script($build_script, [], [@args]) +} + +1; + +__END__ + + +=head1 NAME + +DistGen - Creates simple distributions for testing. + +=head1 SYNOPSIS + + use DistGen; + + # create distribution and prepare to test + my $dist = DistGen->new(name => 'Foo::Bar'); + $dist->chdir_in; + + # change distribution files + $dist->add_file('t/some_test.t', $contents); + $dist->change_file('MANIFEST.SKIP', $new_contents); + $dist->remove_file('t/some_test.t'); + $dist->regen; + + # undo changes and clean up extraneous files + $dist->revert; + $dist->clean; + + # exercise the command-line interface + $dist->run_build_pl(); + $dist->run_build('test'); + + # start over as a new distribution + $dist->reset( name => 'Foo::Bar', xs => 1 ); + $dist->chdir_in; + +=head1 USAGE + +A DistGen object manages a set of files in a distribution directory. + +The C<new()> constructor initializes the object and creates an empty +directory for the distribution. It does not create files or chdir into +the directory. The C<reset()> method re-initializes the object in a +new directory with new parameters. It also does not create files or change +the current directory. + +Some methods only define the target state of the distribution. They do B<not> +make any changes to the filesystem: + + add_file + change_file + change_build_pl + remove_file + revert + +Other methods then change the filesystem to match the target state of +the distribution: + + clean + regen + remove + +Other methods are provided for a convenience during testing. The +most important is the one to enter the distribution directory: + + chdir_in + +Additional methods portably encapsulate running Build.PL and Build: + + run_build_pl + run_build + +=head1 API + +=head2 Constructors + +=head3 new() + +Create a new object and an empty directory to hold the distribution's files. +If no C<dir> option is provided, it defaults to MBTest->tmpdir, which sets +a different temp directory for Perl core testing and CPAN testing. + +The C<new> method does not write any files -- see L</regen()> below. + + my $dist = DistGen->new( + name => 'Foo::Bar', + version => '0.01', + license => 'perl', + dir => MBTest->tmpdir, + xs => 1, + no_manifest => 0, + ); + +The parameters are as follows. + +=over + +=item name + +The name of the module this distribution represents. The default is +'Simple'. This should be a "Foo::Bar" (module) name, not a "Foo-Bar" +dist name. + +=item version + +The version string that will be set. (E.g. C<our $VERSION = 0.01>) +Note -- to put this value in quotes, add those to the string. + + version => q{'0.01_01'} + +=item license + +The license string that will be set in Build.PL. Defaults to 'perl'. + +=item dir + +The (parent) directory in which to create the distribution directory. The +distribution will be created under this according to C<distdir> parameter +below. Defaults to a temporary directory. + + $dist = DistGen->new( dir => '/tmp/MB-test' ); + $dist->regen; + + # distribution files have been created in /tmp/MB-test/Simple + +=item distdir + +The name of the distribution directory to create. Defaults to the dist form of +C<name>, e.g. 'Foo-Bar' if C<name> is 'Foo::Bar'. + +=item xs + +If true, generates an XS based module. + +=item no_manifest + +If true, C<regen()> will not create a MANIFEST file. + +=back + +The following files are added as part of the default distribution: + + Build.PL + lib/Simple.pm # based on name parameter + t/basic.t + +If an XS module is generated, Simple.pm and basic.t are different and +the following files are also added: + + typemap + lib/Simple.xs # based on name parameter + +=head3 reset() + +The C<reset> method re-initializes the object as if it were generated +from a fresh call to C<new>. It takes the same optional parameters as C<new>. + + $dist->reset( name => 'Foo::Bar', xs => 0 ); + +=head2 Adding and editing files + +Note that C<$filename> should always be specified with unix-style paths, +and are relative to the distribution root directory, e.g. C<lib/Module.pm>. + +No changes are made to the filesystem until the distribution is regenerated. + +=head3 add_file() + +Add a $filename containing $content to the distribution. + + $dist->add_file( $filename, $content ); + +=head3 change_file() + +Changes the contents of $filename to $content. No action is performed +until the distribution is regenerated. + + $dist->change_file( $filename, $content ); + +=head3 change_build_pl() + +A wrapper around change_file specifically for setting Build.PL. Instead +of file C<$content>, it takes a hash-ref of Module::Build constructor +arguments: + + $dist->change_build_pl( + { + module_name => $dist->name, + dist_version => '3.14159265', + license => 'perl', + create_readme => 1, + } + ); + +=head3 get_file + +Retrieves the target contents of C<$filename>. + + $content = $dist->get_file( $filename ); + +=head3 remove_file() + +Removes C<$filename> from the distribution. + + $dist->remove_file( $filename ); + +=head3 revert() + +Returns the object to its initial state, or given a $filename it returns that +file to its initial state if it is one of the built-in files. + + $dist->revert; + $dist->revert($filename); + +=head2 Changing the distribution directory + +These methods immediately affect the filesystem. + +=head3 regen() + +Regenerate all missing or changed files. Also deletes any files +flagged for removal with remove_file(). + + $dist->regen(clean => 1); + +If the optional C<clean> argument is given, it also calls C<clean>. These +can also be chained like this, instead: + + $dist->clean->regen; + +=head3 clean() + +Removes any files that are not part of the distribution. + + $dist->clean; + +=head3 remove() + +Changes back to the original directory and removes the distribution +directory (but not the temporary directory set during C<new()>). + + $dist = DistGen->new->chdir->regen; + # ... do some testing ... + + $dist->remove->chdir_in->regen; + # ... do more testing ... + +This is like a more aggressive form of C<clean>. Generally, calling C<clean> +and C<regen> should be sufficient. + +=head2 Changing directories + +=head3 chdir_in + +Change directory into the dist root. + + $dist->chdir_in; + +=head3 chdir_original + +Returns to whatever directory you were in before chdir_in() (regardless +of the cwd.) + + $dist->chdir_original; + +=head2 Command-line helpers + +These use Module::Build->run_perl_script() to ensure that Build.PL or Build are +run in a separate process using the current perl interpreter. (Module::Build +is loaded on demand). They also ensure appropriate naming for operating +systems that require a suffix for Build. + +=head3 run_build_pl + +Runs Build.PL using the current perl interpreter. Any arguments are +passed on the command line. + + $dist->run_build_pl('--quiet'); + +=head3 run_build + +Runs Build using the current perl interpreter. Any arguments are +passed on the command line. + + $dist->run_build(qw/test --verbose/); + +=head2 Properties + +=head3 name() + +Returns the name of the distribution. + + $dist->name: # e.g. Foo::Bar + +=head3 dirname() + +Returns the directory where the distribution is created. + + $dist->dirname; # e.g. t/_tmp/Simple + +=head2 Functions + +=head3 undent() + +Removes leading whitespace from a multi-line string according to the +amount of whitespace on the first line. + + my $string = undent(" foo(\n bar => 'baz'\n )"); + $string eq "foo( + bar => 'baz' + )"; + +=cut + +# vim:ts=2:sw=2:et:sta diff --git a/t/lib/MBTest.pm b/t/lib/MBTest.pm new file mode 100644 index 0000000..fda7f69 --- /dev/null +++ b/t/lib/MBTest.pm @@ -0,0 +1,314 @@ +package MBTest; + +use strict; + +use File::Spec; +use File::Temp (); +use File::Path (); + + +# Setup the code to clean out %ENV +BEGIN { + # Environment variables which might effect our testing + my @delete_env_keys = qw( + HOME + DEVEL_COVER_OPTIONS + MODULEBUILDRC + PERL_MB_OPT + HARNESS_TIMER + HARNESS_OPTIONS + HARNESS_VERBOSE + PREFIX + INSTALL_BASE + INSTALLDIRS + ); + + # Remember the ENV values because on VMS %ENV is global + # to the user, not the process. + my %restore_env_keys; + + sub clean_env { + for my $key (@delete_env_keys) { + if( exists $ENV{$key} ) { + $restore_env_keys{$key} = delete $ENV{$key}; + } + else { + delete $ENV{$key}; + } + } + } + + END { + while( my($key, $val) = each %restore_env_keys ) { + $ENV{$key} = $val; + } + } +} + + +BEGIN { + clean_env(); + + # In case the test wants to use our other bundled + # modules, make sure they can be loaded. + my $t_lib = File::Spec->catdir('t', 'bundled'); + push @INC, $t_lib; # Let user's installed version override + + # We change directories, so expand @INC and $^X to absolute paths + # Also add . + @INC = (map(File::Spec->rel2abs($_), @INC), "."); + $^X = File::Spec->rel2abs($^X); +} + +use Exporter; +use Test::More; +use Config; +use Cwd (); + +# We pass everything through to Test::More +use vars qw($VERSION @ISA @EXPORT $TODO); +@ISA = ('Exporter'); +$VERSION = 0.01_01; + +# We have a few extra exports, but Test::More has a special import() +# that won't take extra additions. +@EXPORT = ( + qw( + stdout_of + stderr_of + stdout_stderr_of + slurp + find_in_path + check_compiler + have_module + blib_load + timed_out + $TODO + ), + @Test::More::EXPORT, +); + +sub import { + my $class = shift; + my $caller = caller; + + my @imports; + + while (my $item = shift @_) { + if ($item eq 'tests' || $item eq 'skip_all') { + my $arg = shift @_; + plan($item => $arg); + } + elsif($item eq 'no_plan') { + plan($item); + } + else { + push @imports => $item; + } + } + + @imports = @EXPORT unless @imports; + + $class->export($caller, @imports); +} + + +######################################################################## + +# always return to the current directory +{ + my $cwd; + # must be done in BEGIN because tmpdir uses it in BEGIN for $ENV{HOME} + BEGIN { + $cwd = File::Spec->rel2abs(Cwd::cwd); + } + + sub original_cwd { return $cwd } + + END { + # Go back to where you came from! + chdir $cwd or die "Couldn't chdir to $cwd"; + } +} +######################################################################## + +{ # backwards compatible temp filename recipe adapted from perlfaq + my $tmp_count = 0; + my $tmp_base_name = sprintf("MB-%d-%d", $$, time()); + sub temp_file_name { + sprintf("%s-%04d", $tmp_base_name, ++$tmp_count) + } +} +######################################################################## + +# Setup a temp directory +sub tmpdir { + my ($self, @args) = @_; + my $dir = $ENV{PERL_CORE} ? MBTest->original_cwd : File::Spec->tmpdir; + return File::Temp::tempdir('MB-XXXXXXXX', CLEANUP => 1, DIR => $dir, @args); +} + +BEGIN { + $ENV{HOME} = tmpdir; # don't want .modulebuildrc or other things interfering +} + +sub save_handle { + my ($handle, $subr) = @_; + my $outfile = File::Spec->catfile(File::Spec->tmpdir, temp_file_name()); + + local *SAVEOUT; + open SAVEOUT, ">&" . fileno($handle) + or die "Can't save output handle: $!"; + open $handle, "> $outfile" or die "Can't create $outfile: $!"; + + eval {$subr->()}; + open $handle, ">&SAVEOUT" or die "Can't restore output: $!"; + + my $ret = slurp($outfile); + 1 while unlink $outfile; + return $ret; +} + +sub stdout_of { save_handle(\*STDOUT, @_) } +sub stderr_of { save_handle(\*STDERR, @_) } +sub stdout_stderr_of { + my $subr = shift; + my ($stdout, $stderr); + $stdout = stdout_of ( sub { + $stderr = stderr_of( $subr ) + }); + return wantarray ? ($stdout, $stderr) : $stdout . $stderr; +} + +sub slurp { + open(my $fh, '<', $_[0]) or die "Can't open $_[0]: $!"; + local $/; + return scalar <$fh>; +} + +# Some extensions we should know about if we're looking for executables +sub exe_exts { + + if ($^O eq 'MSWin32') { + return split($Config{path_sep}, $ENV{PATHEXT} || '.com;.exe;.bat'); + } + if ($^O eq 'os2') { + return qw(.exe .com .pl .cmd .bat .sh .ksh); + } + return; +} + +sub find_in_path { + my $thing = shift; + + my @exe_ext = exe_exts(); + if ( File::Spec->file_name_is_absolute( $thing ) ) { + foreach my $ext ( '', @exe_ext ) { + return "$thing$ext" if -e "$thing$ext"; + } + } + else { + my @path = split $Config{path_sep}, $ENV{PATH}; + foreach (@path) { + my $fullpath = File::Spec->catfile($_, $thing); + foreach my $ext ( '', @exe_ext ) { + return "$fullpath$ext" if -e "$fullpath$ext"; + } + } + } + return; +} + +sub check_compiler { + if ($ENV{PERL_CORE}) { + require IPC::Cmd; + if ( $Config{usecrosscompile} && !IPC::Cmd::can_run($Config{cc}) ) { + return; + } + else { + return(1,1); + } + } + + local $SIG{__WARN__} = sub {}; + + blib_load('Module::Build'); + my $mb = Module::Build->current; + $mb->verbose( 0 ); + + my $have_c_compiler; + stderr_of( sub {$have_c_compiler = $mb->have_c_compiler} ); + # XXX link_executable() is not yet implemented for Windows + # and noexec tmpdir is irrelevant on Windows + return ($have_c_compiler, 1) if $^O eq "MSWin32"; + + # check noexec tmpdir + my $tmp_exec; + if ( $have_c_compiler ) { + my $dir = MBTest->tmpdir; + my $c_file = File::Spec->catfile($dir,'test.c'); + open my $fh, ">", $c_file; + print {$fh} "int main() { return 0; }\n"; + close $fh; + my $exe = $mb->cbuilder->link_executable( + objects => $mb->cbuilder->compile( source => $c_file ) + ); + $tmp_exec = 0 == system( $exe ); + } + return ($have_c_compiler, $tmp_exec); +} + +sub have_module { + my $module = shift; + return eval "require $module; 1"; +} + +sub blib_load { + # Load the given module and ensure it came from blib/, not the larger system + my $mod = shift; + have_module($mod) or die "Error loading $mod\: $@\n"; + + (my $path = $mod) =~ s{::}{/}g; + $path .= ".pm"; + my ($pkg, $file, $line) = caller; + unless($ENV{PERL_CORE}) { + unless($INC{$path} =~ m/\bblib\b/) { + (my $load_from = $INC{$path}) =~ s{$path$}{}; + die "$mod loaded from '$load_from'\nIt should have been loaded from blib. \@INC contains:\n ", + join("\n ", @INC) . "\nFatal error occured in blib_load() at $file, line $line.\n"; + } + } +} + +sub timed_out { + my ($sub, $timeout) = @_; + return unless $sub; + $timeout ||= 60; + + my $saw_alarm = 0; + eval { + local $SIG{ALRM} = sub { $saw_alarm++; die "alarm\n"; }; # NB: \n required + alarm $timeout; + $sub->(); + alarm 0; + }; + if ($@) { + die unless $@ eq "alarm\n"; # propagate unexpected errors + } + return $saw_alarm; +} + +sub check_EUI { + my $timed_out; + stdout_stderr_of( sub { + $timed_out = timed_out( sub { + ExtUtils::Installed->new(extra_libs => [@INC]) + } + ); + } + ); + return ! $timed_out; +} + +1; +# vim:ts=2:sw=2:et:sta diff --git a/t/lib/Module/Signature.pm b/t/lib/Module/Signature.pm new file mode 100644 index 0000000..2d58f7d --- /dev/null +++ b/t/lib/Module/Signature.pm @@ -0,0 +1,11 @@ +package Module::Signature; # mocked +use strict; +use warnings; +our $VERSION = 999; + +sub sign { + open my $fh, ">", "SIGNATURE"; + print {$fh} "SIGNATURE"; +} + +1; diff --git a/t/lib/Software/License/VaporWare.pm b/t/lib/Software/License/VaporWare.pm new file mode 100644 index 0000000..80d9fa5 --- /dev/null +++ b/t/lib/Software/License/VaporWare.pm @@ -0,0 +1,17 @@ +use strict; +use warnings; + +package Software::License::VaporWare; +our $VERSION = '0.001'; + +use Software::License; +our @ISA = qw/Software::License/; + +sub name { 'VaporWare License' } +sub url { 'http://example.com/vaporware/' } +sub meta_name { 'unrestricted' } +sub meta2_name { 'unrestricted' } + +1; + + diff --git a/t/manifypods.t b/t/manifypods.t new file mode 100644 index 0000000..de2a3e4 --- /dev/null +++ b/t/manifypods.t @@ -0,0 +1,158 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest; +blib_load('Module::Build'); +blib_load('Module::Build::ConfigData'); + +if ( Module::Build::ConfigData->feature('manpage_support') ) { + plan tests => 21; +} else { + plan skip_all => 'manpage_support feature is not enabled'; +} + + +######################### + + +use Cwd (); +my $cwd = Cwd::cwd; +my $tmp = MBTest->tmpdir; + +use DistGen; +my $dist = DistGen->new( dir => $tmp ); +$dist->add_file( 'bin/nopod.pl', <<'---' ); +#!perl -w +print "sample script without pod to test manifypods action\n"; +--- +$dist->add_file( 'bin/haspod.pl', <<'---' ); +#!perl -w +print "Hello, world"; + +__END__ + +=head1 NAME + +haspod.pl - sample script with pod to test manifypods action + +=cut +--- +$dist->add_file( 'lib/Simple/NoPod.pm', <<'---' ); +package Simple::NoPod; +1; +--- +$dist->add_file( 'lib/Simple/AllPod.pod', <<'---' ); +=head1 NAME + +Simple::AllPod - Pure POD + +=head1 AUTHOR + +Simple Man <simple@example.com> + +=cut +--- +$dist->regen; + + +$dist->chdir_in; + +use File::Spec::Functions qw( catdir ); +my $destdir = catdir($cwd, 't', 'install_test' . $$); + + +my $mb = Module::Build->new( + module_name => $dist->name, + install_base => $destdir, + scripts => [ File::Spec->catfile( 'bin', 'nopod.pl' ), + File::Spec->catfile( 'bin', 'haspod.pl' ) ], + + # Need default install paths to ensure manpages get generated + installdirs => 'site', + config => { + installsiteman1dir => catdir($tmp, 'site', 'man', 'man1'), + installsiteman3dir => catdir($tmp, 'site', 'man', 'man3'), + } + +); + +$mb->add_to_cleanup($destdir); + + +is( ref $mb->{properties}->{bindoc_dirs}, 'ARRAY', 'bindoc_dirs' ); +is( ref $mb->{properties}->{libdoc_dirs}, 'ARRAY', 'libdoc_dirs' ); + +my %man = ( + sep => $mb->manpage_separator, + dir1 => 'man1', + dir3 => 'man3', + ext1 => $mb->config('man1ext'), + ext3 => $mb->config('man3ext'), + ); + +my %distro = ( + 'bin/nopod.pl' => '', + 'bin/haspod.pl' => "haspod.pl.$man{ext1}", + 'lib/Simple.pm' => "Simple.$man{ext3}", + 'lib/Simple/NoPod.pm' => '', + 'lib/Simple/AllPod.pod' => "Simple$man{sep}AllPod.$man{ext3}", + ); + +%distro = map {$mb->localize_file_path($_), $distro{$_}} keys %distro; + +my $lib_path = $mb->localize_dir_path('lib'); + +# Remove trailing directory delimiter on VMS for compares +$lib_path =~ s/\]// if $^O eq 'VMS'; + +$mb->dispatch('build'); + +eval {$mb->dispatch('docs')}; +is $@, ''; + +while (my ($from, $v) = each %distro) { + if (!$v) { + ok ! $mb->contains_pod($from), "$from should not contain POD"; + next; + } + + my $to = File::Spec->catfile('blib', ($from =~ /^[\.\/\[]*lib/ ? 'libdoc' : 'bindoc'), $v); + ok $mb->contains_pod($from), "$from should contain POD"; + ok -e $to, "Created $to manpage"; +} + + +$mb->dispatch('install'); + +while (my ($from, $v) = each %distro) { + next unless $v; + my $to = File::Spec->catfile + ($destdir, 'man', $man{($from =~ /^\Q$lib_path\E/ ? 'dir3' : 'dir1')}, $v); + ok -e $to, "Created $to manpage"; +} + +$mb->dispatch('realclean'); + + +# revert to a pristine state +$dist->regen( clean => 1 ); + +my $mb2 = Module::Build->new( + module_name => $dist->name, + libdoc_dirs => [qw( foo bar baz )], +); + +is( $mb2->{properties}->{libdoc_dirs}->[0], 'foo', 'override libdoc_dirs' ); + +# Make sure we can find our own action documentation +ok $mb2->get_action_docs('build'); +ok !eval{$mb2->get_action_docs('foo')}; + +# Make sure those docs are the correct ones +foreach ('testcover', 'disttest') { + my $docs = $mb2->get_action_docs($_); + like $docs, qr/=item $_/; + unlike $docs, qr/\n=/, $docs; +} + diff --git a/t/manifypods_with_utf8.t b/t/manifypods_with_utf8.t new file mode 100644 index 0000000..ebb0db6 --- /dev/null +++ b/t/manifypods_with_utf8.t @@ -0,0 +1,68 @@ +package ManifypodsWithUtf8; +use strict; +use utf8; +use Test::More; + +use lib 't/lib'; +blib_load('Module::Build'); +blib_load('Module::Build::ConfigData'); + +SKIP: { + unless ( Module::Build::ConfigData->feature('manpage_support') ) { + skip 'manpage_support feature is not enabled'; + } +} + +use MBTest tests => 2; +use File::Spec::Functions qw( catdir ); + +use Cwd (); +my $cwd = Cwd::cwd; +my $tmp = MBTest->tmpdir; + +use DistGen; +my $dist = DistGen->new( dir => $tmp ); +my $content = <<'---'; + +=encoding utf8 + +=head1 NAME + +Simple::PodWithUtf8 - POD with some (ç á à ô) special chars + +=cut +--- +utf8::encode($content); +$dist->add_file( 'lib/Simple/PodWithUtf8.pod', $content); +$dist->regen; +$dist->chdir_in; + +my $destdir = catdir($cwd, 't', 'install_test' . $$); + +my $mb = Module::Build->new( + module_name => $dist->name, + install_base => $destdir, + + # need default install paths to ensure manpages get generated + installdirs => 'site', + config => { + installsiteman1dir => catdir($tmp, 'site', 'man', 'man1'), + installsiteman3dir => catdir($tmp, 'site', 'man', 'man3'), + }, + extra_manify_args => { utf8 => 1 }, + ); +$mb->add_to_cleanup($destdir); + + +$mb->dispatch('build'); +my $sep = $mb->manpage_separator; +my $ext3 = $mb->config('man3ext'); +my $to = File::Spec->catfile('blib', 'libdoc', "Simple${sep}PodWithUtf8.${ext3}"); + +ok(-e $to, "Manpage is found at $to"); +open my $pod, '<:encoding(utf-8)', $to or diag "Could not open $to: $!"; +my $pod_content = do { local $/; <$pod> }; +close $pod; + +like($pod_content, qr/ \(ç á à ô\) /, "POD should contain special characters"); + diff --git a/t/metadata.t b/t/metadata.t new file mode 100755 index 0000000..ae9a5af --- /dev/null +++ b/t/metadata.t @@ -0,0 +1,109 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest tests => 14; + +blib_load('Module::Build'); +blib_load('Module::Build::ConfigData'); + +my $tmp = MBTest->tmpdir; + +my %metadata = + ( + module_name => 'Simple', + dist_version => '3.14159265', + dist_author => [ 'Simple Simon <ss\@somewhere.priv>' ], + dist_abstract => 'Something interesting', + test_requires => { + 'Test::More' => 0.49, + }, + license => 'perl', + meta_add => { + keywords => [qw(super duper something)], + resources => {homepage => 'http://foo.example.com'}, + }, + ); + + +use DistGen; +my $dist = DistGen->new( dir => $tmp ); +$dist->change_build_pl( \%metadata ); +$dist->regen; + +my $simple_file = 'lib/Simple.pm'; +my $simple2_file = 'lib/Simple2.pm'; + + # Traditional VMS will return the file in in lower case, and is_deeply + # does exact case comparisons. + # When ODS-5 support is active for preserved case file names we do not + # change the case. + if ($^O eq 'VMS') { + my $lower_case_expect = 1; + my $vms_efs_case = 0; + if (eval 'require VMS::Feature') { + $vms_efs_case = VMS::Feature::current("efs_case_preserve"); + } else { + my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || ''; + $vms_efs_case = $efs_case =~ /^[ET1]/i; + } + $lower_case_expect = 0 if $vms_efs_case; + if ($lower_case_expect) { + $simple_file = lc($simple_file); + $simple2_file = lc($simple2_file); + } + } + + +$dist->chdir_in; + +my $mb = Module::Build->new_from_context; + +################################################## +# +# Test for valid META.yml + +{ + my $mb_prereq = { 'Module::Build' => $Module::Build::VERSION }; + my $mb_config_req = { + 'Module::Build' => sprintf '%2.2f', int($Module::Build::VERSION * 100)/100 + }; + my $node; + my $output = stdout_stderr_of( sub { + $node = $mb->get_metadata( auto => 1 ); + }); + like( $output, qr/Module::Build was not found in configure_requires/, + "saw warning about M::B not in configure_requires" + ); + + # exists() doesn't seem to work here + is $node->{name}, $metadata{module_name}; + is $node->{version}, $metadata{dist_version}; + is $node->{abstract}, $metadata{dist_abstract}; + is_deeply $node->{author}, $metadata{dist_author}; + is_deeply $node->{license}, [ 'perl_5' ]; + is_deeply $node->{prereqs}{configure}{requires}, $mb_config_req, 'Add M::B to configure_requires'; + is_deeply $node->{prereqs}{test}{requires}, { + 'Test::More' => '0.49', + }, 'Test::More was required by ->new'; + like $node->{generated_by}, qr{Module::Build}; + ok defined( $node->{'meta-spec'}{version} ), + "'meta-spec' -> 'version' field present in META.yml"; + ok defined( $node->{'meta-spec'}{url} ), + "'meta-spec' -> 'url' field present in META.yml"; + is_deeply $node->{keywords}, $metadata{meta_add}{keywords}; + is_deeply $node->{resources}, $metadata{meta_add}{resources}; +} + +{ + my $mb_prereq = { 'Module::Build' => 0 }; + $mb->configure_requires( $mb_prereq ); + my $node = $mb->get_metadata( auto => 1 ); + + + # exists() doesn't seem to work here + is_deeply $node->{prereqs}{configure}{requires}, $mb_prereq, 'Add M::B to configure_requires'; +} + +$dist->clean; + diff --git a/t/metadata2.t b/t/metadata2.t new file mode 100644 index 0000000..347a9a4 --- /dev/null +++ b/t/metadata2.t @@ -0,0 +1,128 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest tests => 18; + +blib_load('Module::Build'); +blib_load('Module::Build::ConfigData'); + +use DistGen; + + +############################## ACTION distmeta works without a MANIFEST file + +{ + my $dist = DistGen->new( no_manifest => 1 )->chdir_in->regen; + + ok ! -e 'MANIFEST'; + + my $mb; + stderr_of( sub { $mb = Module::Build->new_from_context } ); + + my $out; + $out = eval { stderr_of(sub{$mb->dispatch('distmeta')}) }; + is $@, ''; + + like $out, qr/Nothing to enter for 'provides'/; + + ok -e 'META.yml'; + +} + + +############################## Check generation of README file + +# TODO: We need to test faking the absence of Pod::Readme when present +# so Pod::Text will be used. Also fake the absence of both to +# test that we fail gracefully. + +my $provides; # Used a bunch of times below + +my $pod_text = <<'---'; +=pod + +=head1 NAME + +Simple - A simple module + +=head1 AUTHOR + +Simple Simon <simon@simple.sim> + +=cut +--- + +my $dist = DistGen->new->chdir_in; + +$dist->change_build_pl +({ + module_name => $dist->name, + dist_version => '3.14159265', + license => 'perl', + create_readme => 1, +}); + +# .pm File with pod +# + +$dist->change_file( 'lib/Simple.pm', <<'---' . $pod_text); +package Simple; +$VERSION = '1.23'; +--- +$dist->regen( clean => 1 ); +ok( -e "lib/Simple.pm", "Creating Simple.pm" ); +my $mb = Module::Build->new_from_context; +$mb->do_create_readme; +like( slurp("README"), qr/NAME/, + "Generating README from .pm"); +is( $mb->dist_author->[0], 'Simple Simon <simon@simple.sim>', + "Extracting AUTHOR from .pm"); +is( $mb->dist_abstract, "A simple module", + "Extracting abstract from .pm"); + +# .pm File with pod in separate file +# + +$dist->change_file( 'lib/Simple.pm', <<'---'); +package Simple; +$VERSION = '1.23'; +--- +$dist->change_file( 'lib/Simple.pod', $pod_text ); +$dist->regen( clean => 1 ); + +ok( -e "lib/Simple.pm", "Creating Simple.pm" ); +ok( -e "lib/Simple.pod", "Creating Simple.pod" ); +$mb = Module::Build->new_from_context; +$mb->do_create_readme; +like( slurp("README"), qr/NAME/, "Generating README from .pod"); +is( $mb->dist_author->[0], 'Simple Simon <simon@simple.sim>', + "Extracting AUTHOR from .pod"); +is( $mb->dist_abstract, "A simple module", + "Extracting abstract from .pod"); + +# .pm File with pod and separate pod file +# + +$dist->change_file( 'lib/Simple.pm', <<'---' ); +package Simple; +$VERSION = '1.23'; + +=pod + +=head1 DONT USE THIS FILE FOR POD + +=cut +--- +$dist->change_file( 'lib/Simple.pod', $pod_text ); +$dist->regen( clean => 1 ); +ok( -e "lib/Simple.pm", "Creating Simple.pm" ); +ok( -e "lib/Simple.pod", "Creating Simple.pod" ); +$mb = Module::Build->new_from_context; +$mb->do_create_readme; +like( slurp("README"), qr/NAME/, "Generating README from .pod over .pm"); +is( $mb->dist_author->[0], 'Simple Simon <simon@simple.sim>', + "Extracting AUTHOR from .pod over .pm"); +is( $mb->dist_abstract, "A simple module", + "Extracting abstract from .pod over .pm"); + diff --git a/t/mymeta.t b/t/mymeta.t new file mode 100644 index 0000000..73cda05 --- /dev/null +++ b/t/mymeta.t @@ -0,0 +1,170 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest; +use CPAN::Meta 2.110420; +use CPAN::Meta::YAML; +use Parse::CPAN::Meta 1.4401; +plan tests => 41; + +blib_load('Module::Build'); + +my $tmp = MBTest->tmpdir; + +use DistGen; +my $dist = DistGen->new( dir => $tmp ); +$dist->change_file('Build.PL', <<"---"); +use strict; +use Module::Build; + +my \$builder = Module::Build->new( + module_name => '$dist->{name}', + license => 'perl', + requires => { + 'File::Spec' => ( \$ENV{BUMP_PREREQ} ? 0.86 : 0 ), + }, + configure_requires => { + 'Module::Build' => '0.42', + } +); + +\$builder->create_build_script(); +--- +$dist->regen; +$dist->chdir_in; + +######################### + +# Test MYMETA generation +{ + ok( ! -e "META.yml", "META.yml doesn't exist before Build.PL runs" ); + ok( ! -e "MYMETA.yml", "MYMETA.yml doesn't exist before Build.PL runs" ); + ok( ! -e "META.json", "META.json doesn't exist before Build.PL runs" ); + ok( ! -e "MYMETA.json", "MYMETA.json doesn't exist before Build.PL runs" ); + my $output; + $output = stdout_of sub { $dist->run_build_pl }; + like($output, qr/Created MYMETA\.yml and MYMETA\.json/, + "Ran Build.PL and saw MYMETA.yml creation message" + ); + ok( -e "MYMETA.yml", "MYMETA.yml exists" ); + ok( -e "MYMETA.json", "MYMETA.json exists" ); +} + +######################### + +# Test interactions between META/MYMETA +{ + my $output = stdout_stderr_of sub { $dist->run_build('distmeta') }; + like($output, qr/Created META\.yml and META\.json/, + "Ran Build distmeta to create META.yml"); + # regenerate MYMETA to pick up from META instead of creating from scratch + $output = stdout_of sub { $dist->run_build_pl }; + like($output, qr/Created MYMETA\.yml and MYMETA\.json/, + "Re-ran Build.PL and regenerated MYMETA.yml based on META.yml" + ); + + for my $suffix ( qw/.yml .json/ ) { + my $meta = Parse::CPAN::Meta->load_file("META$suffix"); + my $mymeta = Parse::CPAN::Meta->load_file("MYMETA$suffix"); + is( delete $meta->{dynamic_config}, 1, + "META$suffix 'dynamic_config' is 1" + ); + is( delete $mymeta->{dynamic_config}, 0, + "MYMETA$suffix 'dynamic_config' is 0" + ); + + my $have_url = delete $mymeta->{'meta-spec'}->{url}; + my $want_url = delete $meta->{'meta-spec'}->{url}; + + is_deeply( $mymeta, $meta, "Other generated MYMETA$suffix matches generated META$suffix" ) + or do { + require Data::Dumper; + diag "MYMETA:\n" . Data::Dumper::Dumper($mymeta) + . "META:\n" . Data::Dumper::Dumper($meta); + }; + + like $have_url, qr{Meta(::|-)Spec}i, "CPAN meta spec mentioned in meta-spec URL"; + } + + $output = stdout_stderr_of sub { $dist->run_build('realclean') }; + like( $output, qr/Cleaning up/, "Ran realclean"); + ok( ! -e 'Build', "Build file removed" ); + ok( ! -e 'MYMETA.yml', "MYMETA.yml file removed" ); + ok( ! -e 'MYMETA.json', "MYMETA.json file removed" ); + + # test that dynamic prereq is picked up + my $meta = Parse::CPAN::Meta->load_file("META.yml"); + my $meta2 = Parse::CPAN::Meta->load_file("META.json"); + local $ENV{BUMP_PREREQ} = 1; + $output = stdout_of sub { $dist->run_build_pl }; + like($output, qr/Created MYMETA\.yml and MYMETA\.json/, + "Ran Build.PL with dynamic config" + ); + ok( -e "MYMETA.yml", "MYMETA.yml exists" ); + ok( -e "MYMETA.json", "MYMETA.json exists" ); + my $mymeta = Parse::CPAN::Meta->load_file('MYMETA.yml'); + my $mymeta2 = Parse::CPAN::Meta->load_file('MYMETA.json'); + isnt( $meta->{requires}{'File::Spec'}, + $mymeta->{requires}{'File::Spec'}, + "MYMETA.yml requires differs from META.yml" + ); + isnt( $meta2->{prereqs}{runtime}{requires}{'File::Spec'}, + $mymeta2->{prereqs}{runtime}{requires}{'File::Spec'}, + "MYMETA.json requires differs from META.json" + ); + $output = stdout_stderr_of sub { $dist->run_build('realclean') }; + like( $output, qr/Cleaning up/, "Ran realclean"); + ok( ! -e 'Build', "Build file removed" ); + ok( ! -e 'MYMETA.yml', "MYMETA file removed" ); + ok( ! -e 'MYMETA.json', "MYMETA file removed" ); + + # manually change META and check that changes are preserved + $meta->{author} = ['John Gault']; + $meta2->{author} = ['John Gault']; + ok( CPAN::Meta::YAML->new($meta)->write('META.yml'), + "Wrote manually modified META.yml" ); + ok( CPAN::Meta->new( $meta2 )->save('META.json'), + "Wrote manually modified META.json" ); + + $output = stdout_of sub { $dist->run_build_pl }; + like($output, qr/Created MYMETA\.yml and MYMETA\.json/, + "Ran Build.PL" + ); + $mymeta = Parse::CPAN::Meta->load_file('MYMETA.yml'); + $mymeta2 = Parse::CPAN::Meta->load_file('MYMETA.json'); + is_deeply( $mymeta->{author}, [ 'John Gault' ], + "MYMETA.yml preserved META.yml modifications" + ); + is_deeply( $mymeta2->{author}, [ 'John Gault' ], + "MYMETA.json preserved META.json modifications" + ); + +} + +######################### + +# Test cleanup +{ + my $output = stdout_stderr_of sub { $dist->run_build('distcheck') }; + like($output, qr/Creating a temporary 'MANIFEST.SKIP'/, + "MANIFEST.SKIP created for distcheck" + ); + unlike($output, qr/MYMETA/, + "MYMETA not flagged by distcheck" + ); +} + + +{ + my $output = stdout_of sub { $dist->run_build_pl }; + like($output, qr/Created MYMETA\.yml and MYMETA\.json/, + "Ran Build.PL and saw MYMETA.yml creation message" + ); + $output = stdout_stderr_of sub { $dist->run_build('distclean') }; + ok( ! -f 'MYMETA.yml', "No MYMETA.yml after distclean" ); + ok( ! -f 'MYMETA.json', "No MYMETA.json after distclean" ); + ok( ! -f 'MANIFEST.SKIP', "No MANIFEST.SKIP after distclean" ); +} + + diff --git a/t/new_from_context.t b/t/new_from_context.t new file mode 100644 index 0000000..a9ec00b --- /dev/null +++ b/t/new_from_context.t @@ -0,0 +1,26 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest tests => 2; + +blib_load('Module::Build'); + +my $tmp = MBTest->tmpdir; + +use DistGen; +my $dist = DistGen->new( dir => $tmp ); + +my $libdir = 'badlib'; +$dist->add_file("$libdir/Build.PL", 'die'); +$dist->regen; + +$dist->chdir_in; + + +unshift(@INC, $libdir); +my $mb = eval { Module::Build->new_from_context}; +ok(! $@, 'dodged the bullet') or die; +ok($mb); + +# vim:ts=2:sw=2:et:sta diff --git a/t/notes.t b/t/notes.t new file mode 100644 index 0000000..4568e7c --- /dev/null +++ b/t/notes.t @@ -0,0 +1,66 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest tests => 11; + +blib_load('Module::Build'); + +my $tmp = MBTest->tmpdir; + +use DistGen; +my $dist = DistGen->new( dir => $tmp ); +$dist->regen; + +$dist->chdir_in; + + +################################### +$dist->change_file( 'Build.PL', <<"---" ); +use Module::Build; +my \$build = Module::Build->new( + module_name => @{[$dist->name]}, + license => 'perl' +); +\$build->create_build_script; +\$build->notes(foo => 'bar'); +--- + +$dist->regen; + +my $mb = Module::Build->new_from_context; + +is $mb->notes('foo'), 'bar'; + +# Try setting & checking a new value +$mb->notes(argh => 'new'); +is $mb->notes('argh'), 'new'; + +# Change existing value +$mb->notes(foo => 'foo'); +is $mb->notes('foo'), 'foo'; + +# Change back so we can run this test again successfully +$mb->notes(foo => 'bar'); +is $mb->notes('foo'), 'bar'; + +# Check undef vs. 0 vs '' +foreach my $val (undef, 0, '') { + $mb->notes(null => $val); + is $mb->notes('null'), $val; +} + + +################################### +# Make sure notes set before create_build_script() get preserved +$mb = Module::Build->new(module_name => $dist->name); +ok $mb; +$mb->notes(foo => 'bar'); +is $mb->notes('foo'), 'bar'; + +$mb->create_build_script; + +$mb = Module::Build->resume; +ok $mb; +is $mb->notes('foo'), 'bar'; + @@ -0,0 +1,96 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest; +blib_load('Module::Build'); +blib_load('Module::Build::ConfigData'); + +my $tmp; + +{ + my ($have_c_compiler, $tmp_exec) = check_compiler(); + if ( ! $have_c_compiler ) { + plan skip_all => 'No compiler found'; + } elsif ( ! eval {require PAR::Dist; PAR::Dist->VERSION(0.17)} ) { + plan skip_all => "PAR::Dist 0.17 or up not installed to check .par's."; + } elsif ( ! eval {require Archive::Zip} ) { + plan skip_all => "Archive::Zip required."; + } else { + plan tests => 3; + } + require Cwd; + $tmp = MBTest->tmpdir( $tmp_exec ? () : (DIR => Cwd::cwd) ); +} + + + +use DistGen; +my $dist = DistGen->new( dir => $tmp, xs => 1 ); +$dist->add_file( 'hello', <<'---' ); +#!perl -w +print "Hello, World!\n"; +__END__ + +=pod + +=head1 NAME + +hello + +=head1 DESCRIPTION + +Says "Hello" + +=cut +--- +$dist->change_build_pl +({ + module_name => $dist->name, + version => '0.01', + license => 'perl', + scripts => [ 'hello' ], +}); +$dist->regen; + +$dist->chdir_in; + +use File::Spec::Functions qw(catdir); + +my @installstyle = qw(lib perl5); +my $mb = Module::Build->new_from_context( + verbose => 0, + quiet => 1, + + installdirs => 'site', +); + +my $filename = $mb->dispatch('pardist'); + +ok( -f $filename, '.par distributions exists' ); +my $distname = $dist->name; +ok( $filename =~ /^\Q$distname\E/, 'Distribution name seems correct' ); + +#--------------------------------------------------------------------------# +# must work around broken Archive::Zip (1.28) which breaks PAR::Dist +#--------------------------------------------------------------------------# + +SKIP: { + my $zip = Archive::Zip->new; + my $tmp2 = MBTest->tmpdir; + local %SIG; + $SIG{__WARN__} = sub { print STDERR $_[0] unless $_[0] =~ /\bstat\b/ }; + skip "broken Archive::Zip", 1 + unless eval { $zip->read($filename) == Archive::Zip::AZ_OK() } + && eval { $zip->extractTree('', "$tmp2/") == Archive::Zip::AZ_OK() } + && -r File::Spec->catfile( $tmp2, 'blib', 'META.yml' ); + + my $meta; + eval { $meta = PAR::Dist::get_meta($filename) }; + + ok( + (not $@ and defined $meta and not $meta eq ''), + 'Distribution contains META.yml' + ); +} + diff --git a/t/parents.t b/t/parents.t new file mode 100644 index 0000000..825f79a --- /dev/null +++ b/t/parents.t @@ -0,0 +1,61 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest tests => 26; + +blib_load('Module::Build'); + +######################### + +package Foo; +sub foo; + +package MySub1; +use base 'Module::Build'; + +package MySub2; +use base 'MySub1'; + +package MySub3; +use base qw(MySub2 Foo); + +package MyTest; +use base 'Module::Build'; + +package MyBulk; +use base qw(MySub2 MyTest); + +package main; + +ok my @parents = MySub1->mb_parents; +# There will be at least one platform class in between. +ok @parents >= 2; +# They should all inherit from Module::Build::Base; +ok ! grep { !$_->isa('Module::Build::Base') } @parents; +is $parents[0], 'Module::Build'; +is $parents[-1], 'Module::Build::Base'; + +ok @parents = MySub2->mb_parents; +ok @parents >= 3; +ok ! grep { !$_->isa('Module::Build::Base') } @parents; +is $parents[0], 'MySub1'; +is $parents[1], 'Module::Build'; +is $parents[-1], 'Module::Build::Base'; + +ok @parents = MySub3->mb_parents; +ok @parents >= 4; +ok ! grep { !$_->isa('Module::Build::Base') } @parents; +is $parents[0], 'MySub2'; +is $parents[1], 'MySub1'; +is $parents[2], 'Module::Build'; +is $parents[-1], 'Module::Build::Base'; + +ok @parents = MyBulk->mb_parents; +ok @parents >= 5; +ok ! grep { !$_->isa('Module::Build::Base') } @parents; +is $parents[0], 'MySub2'; +is $parents[1], 'MySub1'; +is $parents[2], 'Module::Build'; +is $parents[-2], 'Module::Build::Base'; +is $parents[-1], 'MyTest'; diff --git a/t/perl_mb_opt.t b/t/perl_mb_opt.t new file mode 100644 index 0000000..70089ee --- /dev/null +++ b/t/perl_mb_opt.t @@ -0,0 +1,62 @@ +# sample.t -- a sample test file for Module::Build + +use strict; +use lib 't/lib'; +use MBTest; +use DistGen; + +plan tests => 8; # or 'no_plan' + +# Ensure any Module::Build modules are loaded from correct directory +blib_load('Module::Build'); + +# create dist object in a temp directory +# enter the directory and generate the skeleton files +my $dist = DistGen->new->chdir_in->regen; + +$dist->add_file('t/subtest/foo.t', <<'END_T'); +use strict; +use Test::More tests => 1; +ok(1, "this is a recursive test"); +END_T + +$dist->regen; + +# get a Module::Build object and test with it +my $mb = $dist->new_from_context(); # quiet by default +isa_ok( $mb, "Module::Build" ); +is( $mb->dist_name, "Simple", "dist_name is 'Simple'" ); +ok( ! $mb->recursive_test_files, "set for no recursive testing" ); + +# set for recursive testing using PERL_MB_OPT +{ + local $ENV{PERL_MB_OPT} = "--verbose --recursive_test_files 1"; + + my $out = stdout_stderr_of( sub { + $dist->run_build('test'); + }); + like( $out, qr/this is a recursive test/, + "recursive tests run via PERL_MB_OPT" + ); +} + +# set Build.PL opts using PERL_MB_OPT +{ + local $ENV{PERL_MB_OPT} = "--verbose --recursive_test_files 1"; + my $mb = $dist->new_from_context(); # quiet by default + ok( $mb->recursive_test_files, "PERL_MB_OPT set recusive tests in Build.PL" ); + ok( $mb->verbose, "PERL_MB_OPT set verbose in Build.PL" ); +} + +# verify settings preserved during 'Build test' +{ + ok( !$ENV{PERL_MB_OPT}, "PERL_MB_OPT cleared" ); + my $out = stdout_stderr_of( sub { + $dist->run_build('test'); + }); + like( $out, qr/this is a recursive test/, + "recursive tests run via Build object" + ); +} + +# vim:ts=2:sw=2:et:sta:sts=2 diff --git a/t/pod_parser.t b/t/pod_parser.t new file mode 100644 index 0000000..d4ebcdc --- /dev/null +++ b/t/pod_parser.t @@ -0,0 +1,137 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest tests => 14; + +blib_load('Module::Build::PodParser'); + +######################### + +{ + package IO::StringBased; + + sub TIEHANDLE { + my ($class, $string) = @_; + return bless { + data => [ map "$_\n", split /\n/, $string], + }, $class; + } + + sub READLINE { + shift @{ shift()->{data} }; + } +} + +local *FH; +tie *FH, 'IO::StringBased', <<'EOF'; +=head1 NAME + +Foo::Bar - Perl extension for blah blah blah + +=head1 AUTHOR + +C<Foo::Bar> was written by Engelbert Humperdinck I<E<lt>eh@example.comE<gt>> in 2004. + +Home page: http://example.com/~eh/ + +=cut +EOF + + +my $pp = Module::Build::PodParser->new(fh => \*FH); +ok $pp, 'object created'; + +is $pp->get_author->[0], 'C<Foo::Bar> was written by Engelbert Humperdinck I<E<lt>eh@example.comE<gt>> in 2004.', 'author'; +is $pp->get_abstract, 'Perl extension for blah blah blah', 'abstract'; + + +{ + # Try again without a valid author spec + untie *FH; + tie *FH, 'IO::StringBased', <<'EOF'; +=head1 NAME + +Foo::Bar - Perl extension for blah blah blah + +=cut +EOF + + my $pp = Module::Build::PodParser->new(fh => \*FH); + ok $pp, 'object created'; + + is_deeply $pp->get_author, [], 'author'; + is $pp->get_abstract, 'Perl extension for blah blah blah', 'abstract'; +} + + +{ + # Try again with mixed-case =head1s. + untie *FH; + tie *FH, 'IO::StringBased', <<'EOF'; +=head1 Name + +Foo::Bar - Perl extension for blah blah blah + +=head1 Author + +C<Foo::Bar> was written by Engelbert Humperdinck I<E<lt>eh@example.comE<gt>> in 2004. + +Home page: http://example.com/~eh/ + +=cut +EOF + + my $pp = Module::Build::PodParser->new(fh => \*FH); + ok $pp, 'object created'; + + is $pp->get_author->[0], 'C<Foo::Bar> was written by Engelbert Humperdinck I<E<lt>eh@example.comE<gt>> in 2004.', 'author'; + is $pp->get_abstract, 'Perl extension for blah blah blah', 'abstract'; +} + + +{ + # Now with C<Module::Name> + untie *FH; + tie *FH, 'IO::StringBased', <<'EOF'; +=head1 Name + +C<Foo::Bar> - Perl extension for blah blah blah + +=head1 Author + +C<Foo::Bar> was written by Engelbert Humperdinck I<E<lt>eh@example.comE<gt>> in 2004. + +Home page: http://example.com/~eh/ + +=cut +EOF + + my $pp = Module::Build::PodParser->new(fh => \*FH); + ok $pp, 'object created'; + + is $pp->get_author->[0], 'C<Foo::Bar> was written by Engelbert Humperdinck I<E<lt>eh@example.comE<gt>> in 2004.', 'author'; + is $pp->get_abstract, 'Perl extension for blah blah blah', 'abstract'; +} + +{ +local *FH; +tie *FH, 'IO::StringBased', <<'EOF'; +=head1 NAME + +Foo_Bar - Perl extension for eating pie + +=head1 AUTHOR + +C<Foo_Bar> was written by Engelbert Humperdinck I<E<lt>eh@example.comE<gt>> in 2004. + +Home page: http://example.com/~eh/ + +=cut +EOF + + + my $pp = Module::Build::PodParser->new(fh => \*FH); + ok $pp, 'object created'; + is $pp->get_abstract, 'Perl extension for eating pie', 'abstract'; +} @@ -0,0 +1,223 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest; +use Config; + +blib_load('Module::Build'); +blib_load('Module::Build::ConfigData'); +my $PPM_support = Module::Build::ConfigData->feature('PPM_support'); +my $manpage_support = Module::Build::ConfigData->feature('manpage_support'); +my $HTML_support = Module::Build::ConfigData->feature('HTML_support'); + +my $tmp; + +{ + my ($have_c_compiler, $tmp_exec) = check_compiler(); + if ( ! $have_c_compiler ) { + plan skip_all => 'No compiler found'; + } elsif ( ! $PPM_support ) { + plan skip_all => 'PPM support modules not installed'; + } elsif ( !$Config{usedl} ) { + plan skip_all => 'Perl not compiled for dynamic loading'; + } elsif ( ! $HTML_support ) { + plan skip_all => "HTML support not installed"; + } elsif ( ! eval {require Archive::Tar} ) { + plan skip_all => "Archive::Tar not installed to read archives."; + } elsif ( ! eval {IO::Zlib->VERSION(1.01)} ) { + plan skip_all => "IO::Zlib 1.01 required to read compressed archives."; + } elsif ( $^O eq 'VMS' ) { + plan skip_all => "Needs porting work on VMS"; + } else { + plan tests => 12; + } + require Cwd; + $tmp = MBTest->tmpdir( $tmp_exec ? () : (DIR => Cwd::cwd) ); +} + + +use DistGen; +my $dist = DistGen->new( dir => $tmp, xs => 1 ); +$dist->add_file( 'hello', <<'---' ); +#!perl -w +print "Hello, World!\n"; +__END__ + +=pod + +=head1 NAME + +hello + +=head1 DESCRIPTION + +Says "Hello" + +=cut +--- +$dist->change_build_pl +({ + module_name => $dist->name, + license => 'perl', + scripts => [ 'hello' ], +}); +$dist->regen; + +$dist->chdir_in; + +use File::Spec::Functions qw(catdir); + +my @installstyle = qw(lib perl5); +my $mb = Module::Build->new_from_context( + verbose => 0, + quiet => 1, + + installdirs => 'site', + config => { + manpage_reset(), html_reset(), + ( $manpage_support ? + ( installsiteman1dir => catdir($tmp, 'site', 'man', 'man1'), + installsiteman3dir => catdir($tmp, 'site', 'man', 'man3') ) : () ), + ( $HTML_support ? + ( installsitehtml1dir => catdir($tmp, 'site', 'html'), + installsitehtml3dir => catdir($tmp, 'site', 'html') ) : () ), + }, + html_links => 0, +); + + + +$mb->dispatch('ppd', args => {codebase => '/path/to/codebase-xs'}); + +(my $dist_filename = $dist->name) =~ s/::/-/g; +my $ppd = slurp($dist_filename . '.ppd'); + +my $perl_version = Module::Build::PPMMaker->_ppd_version($mb->perl_version); +my $varchname = Module::Build::PPMMaker->_varchname($mb->config); + +# This test is quite a hack since with XML you don't really want to +# do a strict string comparison, but absent an XML parser it's the +# best we can do. +is $ppd, <<"---"; +<SOFTPKG NAME="$dist_filename" VERSION="0.01"> + <ABSTRACT>Perl extension for blah blah blah</ABSTRACT> + <AUTHOR>A. U. Thor, a.u.thor\@a.galaxy.far.far.away</AUTHOR> + <IMPLEMENTATION> + <ARCHITECTURE NAME="$varchname" /> + <CODEBASE HREF="/path/to/codebase-xs" /> + </IMPLEMENTATION> +</SOFTPKG> +--- + + + +$mb->dispatch('ppmdist'); +is $@, ''; + +my $tar = Archive::Tar->new; + +my $tarfile = $mb->ppm_name . '.tar.gz'; +$tar->read( $tarfile, 1 ); + +my $files = { map { $_ => 1 } $tar->list_files }; + +my $fname = 'Simple'; +$fname = DynaLoader::mod2fname([$fname]) if defined &DynaLoader::mod2fname; +exists_ok($files, "blib/arch/auto/Simple/$fname." . $mb->config('dlext')); +exists_ok($files, 'blib/lib/Simple.pm'); +exists_ok($files, 'blib/script/hello'); + +SKIP: { + skip( "manpage_support not enabled.", 2 ) unless $manpage_support; + + exists_ok($files, 'blib/man3/Simple.' . $mb->config('man3ext')); + exists_ok($files, 'blib/man1/hello.' . $mb->config('man1ext')); +} + +SKIP: { + skip( "HTML_support not enabled.", 2 ) unless $HTML_support; + + exists_ok($files, 'blib/html/site/lib/Simple.html'); + exists_ok($files, 'blib/html/bin/hello.html'); +} + +$tar->clear; +undef( $tar ); + +$mb->dispatch('realclean'); +$dist->clean; + + +SKIP: { + skip( "HTML_support not enabled.", 3 ) unless $HTML_support; + + # Make sure html documents are generated for the ppm distro even when + # they would not be built during a normal build. + $mb = Module::Build->new_from_context( + verbose => 0, + quiet => 1, + + installdirs => 'site', + config => { + html_reset(), + installsiteman1dir => catdir($tmp, 'site', 'man', 'man1'), + installsiteman3dir => catdir($tmp, 'site', 'man', 'man3'), + }, + html_links => 0, + ); + + $mb->dispatch('ppmdist'); + is $@, ''; + + $tar = Archive::Tar->new; + $tar->read( $tarfile, 1 ); + + $files = {map { $_ => 1 } $tar->list_files}; + + exists_ok($files, 'blib/html/site/lib/Simple.html'); + exists_ok($files, 'blib/html/bin/hello.html'); + + $tar->clear; + + $mb->dispatch('realclean'); + $dist->clean; +} + + +######################################## + +sub exists_ok { + my $files = shift; + my $file = shift; + local $Test::Builder::Level = $Test::Builder::Level + 1; + ok exists( $files->{$file} ) && $files->{$file}, $file; +} + +# A hash of all Config.pm settings related to installing +# manpages with values set to an empty string. +sub manpage_reset { + return ( + installman1dir => '', + installman3dir => '', + installsiteman1dir => '', + installsiteman3dir => '', + installvendorman1dir => '', + installvendorman3dir => '', + ); +} + +# A hash of all Config.pm settings related to installing +# html documents with values set to an empty string. +sub html_reset { + return ( + installhtmldir => '', + installhtml1dir => '', + installhtml3dir => '', + installsitehtml1dir => '', + installsitehtml3dir => '', + installvendorhtml1dir => '', + installvendorhtml3dir => '', + ); +} + diff --git a/t/properties/dist_suffix.t b/t/properties/dist_suffix.t new file mode 100644 index 0000000..aaee112 --- /dev/null +++ b/t/properties/dist_suffix.t @@ -0,0 +1,33 @@ +# sample.t -- a sample test file for Module::Build + +use strict; +use lib 't/lib'; +use MBTest; +use DistGen; + +plan tests => 2; + +# Ensure any Module::Build modules are loaded from correct directory +blib_load('Module::Build'); + +#--------------------------------------------------------------------------# +# Create test distribution +#--------------------------------------------------------------------------# + +use DistGen; +my $dist = DistGen->new( name => 'Simple::Name' ); + +$dist->change_build_pl( + module_name => 'Simple::Name', + dist_suffix => 'SUFFIX', +)->regen; + +$dist->chdir_in; + +my $mb = $dist->new_from_context(); +isa_ok( $mb, "Module::Build" ); +is( $mb->dist_dir, "Simple-Name-0.01-SUFFIX", + "dist_suffix set correctly" +); + +# vim:ts=2:sw=2:et:sta:sts=2 diff --git a/t/properties/license.t b/t/properties/license.t new file mode 100644 index 0000000..bb7247e --- /dev/null +++ b/t/properties/license.t @@ -0,0 +1,66 @@ +use strict; +use lib 't/lib'; +use MBTest; +use DistGen; + +plan 'no_plan'; + +# Ensure any Module::Build modules are loaded from correct directory +blib_load('Module::Build'); + +#--------------------------------------------------------------------------# +# Create test distribution +#--------------------------------------------------------------------------# + +{ + my $dist = DistGen->new( + name => 'Simple::Name', + version => '0.01', + license => 'perl' + ); + + $dist->regen; + $dist->chdir_in; + + my $mb = $dist->new_from_context(); + isa_ok( $mb, "Module::Build" ); + is( $mb->license, 'perl', + "license 'perl' is valid" + ); + + my $meta = $mb->get_metadata( fatal => 0 ); + + is_deeply( $meta->{license} => [ 'perl_5' ], "META license will be 'perl'" ); + is_deeply( $meta->{resources}{license}, [ "http://dev.perl.org/licenses/" ], + "META license URL is correct" + ); + +} + +{ + my $dist = DistGen->new( + name => 'Simple::Name', + version => '0.01', + license => 'VaporWare' + ); + + $dist->regen; + $dist->chdir_in; + + my $mb = $dist->new_from_context(); + isa_ok( $mb, "Module::Build" ); + is( $mb->license, 'VaporWare', + "license 'VaporWare' is valid" + ); + + my $meta = $mb->get_metadata( fatal => 0 ); + + is_deeply( $meta->{license} => [ 'unrestricted' ], "META license will be 'unrestricted'" ); + is_deeply( $meta->{resources}{license}, [ "http://example.com/vaporware/" ], + "META license URL is correct" + ); + +} + +# Test with alpha number +# vim:ts=2:sw=2:et:sta:sts=2 diff --git a/t/properties/module_name.t b/t/properties/module_name.t new file mode 100644 index 0000000..69aec8e --- /dev/null +++ b/t/properties/module_name.t @@ -0,0 +1,57 @@ +# sample.t -- a sample test file for Module::Build + +use strict; +use lib 't/lib'; +use MBTest; +use DistGen; + +plan tests => 4; + +# Ensure any Module::Build modules are loaded from correct directory +blib_load('Module::Build'); + +my $dist; + +#--------------------------------------------------------------------------# +# try getting module_name from dist_name +#--------------------------------------------------------------------------# + +$dist = DistGen->new( + name => "Not::So::Simple", + distdir => 'Random-Name', +)->chdir_in; + +$dist->change_build_pl( + dist_name => 'Not-So-Simple', + dist_version => 1, +)->regen; + +my $mb = $dist->new_from_context(); +isa_ok( $mb, "Module::Build" ); +is( $mb->module_name, "Not::So::Simple", + "module_name guessed from dist_name" +); + +#--------------------------------------------------------------------------# +# Try getting module_name from dist_version_from +#--------------------------------------------------------------------------# + +$dist->add_file( 'lib/Simple/Name.pm', << 'END_PACKAGE' ); +package Simple::Name; +our $VERSION = 1.23; +1; +END_PACKAGE + +$dist->change_build_pl( + dist_name => 'Random-Name', + dist_version_from => 'lib/Simple/Name.pm', + dist_abstract => "Don't complain about missing abstract", +)->regen( clean => 1 ); + +$mb = $dist->new_from_context(); +isa_ok( $mb, "Module::Build" ); +is( $mb->module_name, "Simple::Name", + "module_name guessed from dist_version_from" +); + +# vim:ts=2:sw=2:et:sta:sts=2 diff --git a/t/properties/needs_compiler.t b/t/properties/needs_compiler.t new file mode 100644 index 0000000..f616dfc --- /dev/null +++ b/t/properties/needs_compiler.t @@ -0,0 +1,125 @@ +# sample.t -- a sample test file for Module::Build + +use strict; +use lib 't/lib'; +use MBTest; +use DistGen; + +plan tests => 19; + +# Ensure any Module::Build modules are loaded from correct directory +blib_load('Module::Build'); + +my $dist = DistGen->new->regen->chdir_in; + +# get a Module::Build object and test with it +my $mb; +stderr_of(sub { + ok( $mb = $dist->new_from_context, "Default Build.PL" ); +}); + +ok( ! $mb->needs_compiler, "needs_compiler is false" ); +ok( ! exists $mb->{properties}{build_requires}{'ExtUtils::CBuilder'}, + "ExtUtils::CBuilder is not in build_requires" +); + +#--------------------------------------------------------------------------# +# try with c_source +#--------------------------------------------------------------------------# +$dist->change_build_pl({ + module_name => $dist->name, + license => 'perl', + c_source => 'src', +}); +$dist->regen; +stderr_of(sub { + ok( $mb = $dist->new_from_context, + "Build.PL with c_source" + ); +}); +is( $mb->c_source, 'src', "c_source is set" ); +ok( $mb->needs_compiler, "needs_compiler is true" ); +ok( exists $mb->{properties}{build_requires}{'ExtUtils::CBuilder'}, + "ExtUtils::CBuilder was added to build_requires" +); + +#--------------------------------------------------------------------------# +# try with xs files +#--------------------------------------------------------------------------# +$dist = DistGen->new(dir => 'MBTest', xs => 1); +$dist->regen; +$dist->chdir_in; + +stderr_of(sub { + ok( $mb = $dist->new_from_context, + "Build.PL with xs files" + ); +}); +ok( $mb->needs_compiler, "needs_compiler is true" ); +ok( exists $mb->{properties}{build_requires}{'ExtUtils::CBuilder'}, + "ExtUtils::CBuilder was added to build_requires" +); + +#--------------------------------------------------------------------------# +# force needs_compiler off, despite xs modules +#--------------------------------------------------------------------------# + +$dist->change_build_pl({ + module_name => $dist->name, + license => 'perl', + needs_compiler => 0, +}); +$dist->regen; + +stderr_of(sub { + ok( $mb = $dist->new_from_context , + "Build.PL with xs files, but needs_compiler => 0" + ); +}); +is( $mb->needs_compiler, 0, "needs_compiler is false" ); +ok( ! exists $mb->{properties}{build_requires}{'ExtUtils::CBuilder'}, + "ExtUtils::CBuilder is not in build_requires" +); + +#--------------------------------------------------------------------------# +# don't override specific EU::CBuilder build_requires +#--------------------------------------------------------------------------# + +$dist->change_build_pl({ + module_name => $dist->name, + license => 'perl', + build_requires => { 'ExtUtils::CBuilder' => 0.2 }, +}); +$dist->regen; + +stderr_of(sub { + ok( $mb = $dist->new_from_context , + "Build.PL with xs files, build_requires EU::CB 0.2" + ); +}); +ok( $mb->needs_compiler, "needs_compiler is true" ); +is( $mb->build_requires->{'ExtUtils::CBuilder'}, 0.2, + "build_requires for ExtUtils::CBuilder is correct version" +); + +#--------------------------------------------------------------------------# +# falsify compiler and test error handling +#--------------------------------------------------------------------------# + +# clear $ENV{CC} so we are sure to fail to find our fake compiler :-) +local $ENV{CC}; + +my $err = stderr_of( sub { + $mb = $dist->new_from_context( config => { cc => "adfasdfadjdjk" } ) +}); +ok( $mb, "Build.PL while hiding compiler" ); +like( $err, qr/no compiler detected/, + "hidden compiler resulted in warning message during Build.PL" +); +eval { $mb->dispatch('build') }; +like( $@, qr/no compiler detected/, + "hidden compiler resulted in fatal message during Build" +); + + +# vim:ts=2:sw=2:et:sta:sts=2 diff --git a/t/properties/release_status.t b/t/properties/release_status.t new file mode 100644 index 0000000..45c7f33 --- /dev/null +++ b/t/properties/release_status.t @@ -0,0 +1,204 @@ +use strict; +use lib 't/lib'; +use MBTest; +use DistGen; + +if ( $] lt 5.008001 ) { + plan skip_all => "dotted-version numbers are buggy before 5.8.1"; +} else { + plan 'no_plan'; +} + +# Ensure any Module::Build modules are loaded from correct directory +blib_load('Module::Build'); + +#--------------------------------------------------------------------------# +# Create test distribution +#--------------------------------------------------------------------------# + +{ + my $dist = DistGen->new( name => 'Simple::Name', version => '0.01' ); + + $dist->change_build_pl( + module_name => 'Simple::Name', + )->regen; + + $dist->chdir_in; + + my $mb = $dist->new_from_context(); + isa_ok( $mb, "Module::Build" ); + is( $mb->release_status, "stable", + "regular version has release_status 'stable'" + ); +} + +{ + my $dist = DistGen->new( name => 'Simple::Name', version => 'v1.2.3' ); + + $dist->change_build_pl( + module_name => 'Simple::Name', + )->regen; + + $dist->chdir_in; + + my $mb = $dist->new_from_context(); + isa_ok( $mb, "Module::Build" ); + is( $mb->release_status, "stable", + "dotted-decimal version has release_status 'stable'" + ); +} + +{ + my $dist = DistGen->new( name => 'Simple::Name', version => q{'0.01_01'} ); + + $dist->change_build_pl( + module_name => 'Simple::Name', + )->regen; + + $dist->chdir_in; + + my $mb = $dist->new_from_context(); + isa_ok( $mb, "Module::Build" ); + is( $mb->release_status, "testing", + "alpha version has release_status 'testing'" + ); +} + +{ + my $dist = DistGen->new( name => 'Simple::Name', version => 'v1.2.3_1' ); + + $dist->change_build_pl( + module_name => 'Simple::Name', + )->regen; + + $dist->chdir_in; + + my $mb = $dist->new_from_context(); + isa_ok( $mb, "Module::Build" ); + is( $mb->release_status, "testing", + "dotted alpha version has release_status 'testing'" + ); +} + +{ + my $dist = DistGen->new( name => 'Simple::Name', version => q{'0.01_01'} ); + + $dist->change_build_pl( + module_name => 'Simple::Name', + release_status => 'unstable', + )->regen; + + $dist->chdir_in; + + my $mb = $dist->new_from_context(); + isa_ok( $mb, "Module::Build" ); + is( $mb->release_status, "unstable", + "explicit 'unstable' keeps release_status 'unstable'" + ); +} + +{ + my $dist = DistGen->new( name => 'Simple::Name', version => '0.01' ); + + $dist->change_build_pl( + module_name => 'Simple::Name', + release_status => 'testing', + )->regen; + + $dist->chdir_in; + + my $mb = $dist->new_from_context(); + isa_ok( $mb, "Module::Build" ); + is( $mb->dist_suffix, "TRIAL", + "regular version marked 'testing' gets 'TRIAL' suffix" + ); +} + +{ + my $dist = DistGen->new( name => 'Simple::Name', version => 'v1.2.3' ); + + $dist->change_build_pl( + module_name => 'Simple::Name', + release_status => 'testing', + )->regen; + + $dist->chdir_in; + + my $mb = $dist->new_from_context(); + isa_ok( $mb, "Module::Build" ); + is( $mb->dist_suffix, "TRIAL", + "dotted version marked 'testing' gets 'TRIAL' suffix" + ); +} + +{ + my $dist = DistGen->new( name => 'Simple::Name', version => '0.01' ); + + $dist->change_build_pl( + module_name => 'Simple::Name', + release_status => 'unstable', + )->regen; + + $dist->chdir_in; + + my $mb = $dist->new_from_context(); + isa_ok( $mb, "Module::Build" ); + is( $mb->dist_suffix, "TRIAL", + "regular version marked 'unstable' gets 'TRIAL' suffix" + ); +} + +{ + my $dist = DistGen->new( name => 'Simple::Name', version => '0.01' ); + + $dist->change_build_pl( + module_name => 'Simple::Name', + release_status => 'beta', + )->regen; + + $dist->chdir_in; + + my $output = stdout_stderr_of sub { $dist->run_build_pl() }; + like( $output, qr/Illegal value 'beta' for release_status/i, + "Got error message for illegal release_status" + ); +} + +{ + my $dist = DistGen->new( name => 'Simple::Name', version => q{'0.01_01'} ); + + $dist->change_build_pl( + module_name => 'Simple::Name', + release_status => 'stable', + )->regen; + + $dist->chdir_in; + + my $output = stdout_stderr_of sub { $dist->run_build_pl() }; + like( $output, qr/Illegal value 'stable' with version '0.01_01'/i, + "Got error message for illegal 'stable' with alpha version" + ); +} + +{ + my $dist = DistGen->new( name => 'Simple::Name', version => q{'0.01_01'} ); + + $dist->change_build_pl( + module_name => 'Simple::Name', + dist_version => '1.23beta1', + )->regen; + + $dist->chdir_in; + + my $mb = $dist->new_from_context(); + isa_ok( $mb, "Module::Build" ); + is( $mb->dist_suffix, "", + "non-standard dist_version does not get a suffix" + ); + is( $mb->release_status, "stable", + "non-standard dist_version defaults to stable release_status" + ); +} + +# Test with alpha number +# vim:ts=2:sw=2:et:sta:sts=2 diff --git a/t/properties/requires.t b/t/properties/requires.t new file mode 100644 index 0000000..6511e80 --- /dev/null +++ b/t/properties/requires.t @@ -0,0 +1,54 @@ +# sample.t -- a sample test file for Module::Build + +use strict; +use lib 't/lib'; +use MBTest; +use DistGen; + +plan tests => 4; + +# Ensure any Module::Build modules are loaded from correct directory +blib_load('Module::Build'); + +my ($dist, $mb, $prereqs); + +#--------------------------------------------------------------------------# +# try undefined prereq version +#--------------------------------------------------------------------------# + +$dist = DistGen->new( name => 'Simple::Requires' ); + +$dist->change_build_pl( + module_name => 'Simple::Requires', + requires => { + 'File::Basename' => undef, + }, +)->regen; + +$dist->chdir_in; + +$mb = $dist->new_from_context(); +isa_ok( $mb, "Module::Build" ); + +$prereqs = $mb->_normalize_prereqs; +is($prereqs->{runtime}{requires}{'File::Basename'}, 0, "undef prereq converted to 0"); + +#--------------------------------------------------------------------------# +# try empty string prereq version +#--------------------------------------------------------------------------# + +$dist->change_build_pl( + module_name => 'Simple::Requires', + requires => { + 'File::Basename' => '', + }, +)->regen; + +$mb = $dist->new_from_context(); +isa_ok( $mb, "Module::Build" ); + +$prereqs = $mb->_normalize_prereqs; +is($prereqs->{runtime}{requires}{'File::Basename'}, 0, "empty string prereq converted to 0"); + + +# vim:ts=2:sw=2:et:sta:sts=2 diff --git a/t/properties/share_dir.t b/t/properties/share_dir.t new file mode 100644 index 0000000..f1cda13 --- /dev/null +++ b/t/properties/share_dir.t @@ -0,0 +1,257 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest; +use File::Spec::Functions qw/catdir catfile/; + +#--------------------------------------------------------------------------# +# Begin testing +#--------------------------------------------------------------------------# + +plan tests => 23; + +blib_load('Module::Build'); + +#--------------------------------------------------------------------------# +# Create test distribution +#--------------------------------------------------------------------------# + +my $tmp = MBTest->tmpdir; + +use DistGen; +my $dist = DistGen->new( dir => $tmp, name => 'Simple::Share' ); +$dist->regen; +$dist->chdir_in; + +#--------------------------------------------------------------------------# +# Test setting 'share_dir' +#--------------------------------------------------------------------------# + +my $mb = $dist->new_from_context; + +# Test without a 'share' dir +ok( $mb, "Created Module::Build object" ); +is( $mb->share_dir, undef, + "default share_dir undef if no 'share' dir exists" +); +ok( ! exists $mb->{properties}{requires}{'File::ShareDir'}, + "File::ShareDir not added to 'requires'" +); + +# Add 'share' dir and an 'other' dir and content +$dist->add_file('share/foo.txt',<< '---'); +This is foo.txt +--- +$dist->add_file('share/subdir/share/anotherbar.txt',<< '---'); +This is anotherbar.txt in a subdir - test for a bug in M::B 0.38 when full path contains 'share/.../*share/...' subdir +--- +$dist->add_file('share/subdir/whatever/anotherfoo.txt',<< '---'); +This is anotherfoo.txt in a subdir - this shoud work on M::B 0.38 +--- +$dist->add_file('other/share/bar.txt',<< '---'); +This is bar.txt +--- +$dist->regen; +ok( -e catfile(qw/share foo.txt/), "Created 'share' directory" ); +ok( -d catfile(qw/share subdir share/), "Created 'share/subdir/share' directory" ); +ok( -d catfile(qw/share subdir whatever/), "Created 'share/subdir/whatever' directory" ); +ok( -e catfile(qw/other share bar.txt/), "Created 'other/share' directory" ); + +# Check default when share_dir is not given +stdout_stderr_of( sub { $mb = $dist->new_from_context }); +is( $mb->share_dir, undef, + "Default share_dir is undef even if 'share' exists" +); +ok( ! exists $mb->{properties}{requires}{'File::ShareDir'}, + "File::ShareDir not added to 'requires'" +); + + +# share_dir set to scalar +$dist->change_build_pl( + { + module_name => $dist->name, + license => 'perl', + share_dir => 'share', + } +); +$dist->regen; +stdout_stderr_of( sub { $mb = $dist->new_from_context }); +is_deeply( $mb->share_dir, { dist => [ 'share' ] }, + "Scalar share_dir set as dist-type share" +); + +# share_dir set to arrayref +$dist->change_build_pl( + { + module_name => $dist->name, + license => 'perl', + share_dir => [ 'share' ], + } +); +$dist->regen; +stdout_stderr_of( sub { $mb = $dist->new_from_context }); +is_deeply( $mb->share_dir, { dist => [ 'share' ] }, + "Arrayref share_dir set as dist-type share" +); + +# share_dir set to hashref w scalar +$dist->change_build_pl( + { + module_name => $dist->name, + license => 'perl', + share_dir => { dist => 'share' }, + } +); +$dist->regen; +stdout_stderr_of( sub { $mb = $dist->new_from_context }); +is_deeply( $mb->share_dir, { dist => [ 'share' ] }, + "Hashref share_dir w/ scalar dist set as dist-type share" +); + +# share_dir set to hashref w array +$dist->change_build_pl( + { + module_name => $dist->name, + license => 'perl', + share_dir => { dist => [ 'share' ] }, + } +); +$dist->regen; +stdout_stderr_of( sub { $mb = $dist->new_from_context }); +is_deeply( $mb->share_dir, { dist => [ 'share' ] }, + "Hashref share_dir w/ arrayref dist set as dist-type share" +); + +# Generate a module sharedir (scalar) +$dist->change_build_pl( + { + module_name => $dist->name, + license => 'perl', + share_dir => { + dist => 'share', + module => { $dist->name => 'other/share' }, + }, + } +); +$dist->regen; +stdout_stderr_of( sub { $mb = $dist->new_from_context }); +is_deeply( $mb->share_dir, + { dist => [ 'share' ], + module => { $dist->name => ['other/share'] }, + }, + "Hashref share_dir w/ both dist and module shares (scalar-form)" +); + +# Generate a module sharedir (array) +$dist->change_build_pl( + { + module_name => $dist->name, + license => 'perl', + share_dir => { + dist => [ 'share' ], + module => { $dist->name => ['other/share'] }, + }, + } +); +$dist->regen; +stdout_stderr_of( sub { $mb = $dist->new_from_context }); +is_deeply( $mb->share_dir, + { dist => [ 'share' ], + module => { $dist->name => ['other/share'] }, + }, + "Hashref share_dir w/ both dist and module shares (array-form)" +); + +#--------------------------------------------------------------------------# +# test constructing to/from mapping +#--------------------------------------------------------------------------# + +is_deeply( $mb->_find_share_dir_files, + { + "share/foo.txt" => "dist/Simple-Share/foo.txt", + "share/subdir/share/anotherbar.txt" => "dist/Simple-Share/subdir/share/anotherbar.txt", + "share/subdir/whatever/anotherfoo.txt" => "dist/Simple-Share/subdir/whatever/anotherfoo.txt", + "other/share/bar.txt" => "module/Simple-Share/bar.txt", + }, + "share_dir filemap for copying to lib complete" +); + +#--------------------------------------------------------------------------# +# test moving files to blib +#--------------------------------------------------------------------------# + +$mb->dispatch('build'); + +ok( -d 'blib', "Build ran and blib exists" ); +ok( -d 'blib/lib/auto/share', "blib/lib/auto/share exists" ); + +my $share_list = Module::Build->rscan_dir('blib/lib/auto/share', sub {-f}); + +SKIP: +{ + +skip 'filename case not necessarily preserved', 1 if $^O eq 'VMS'; + +is_deeply( + [ sort @$share_list ], [ + 'blib/lib/auto/share/dist/Simple-Share/foo.txt', + 'blib/lib/auto/share/dist/Simple-Share/subdir/share/anotherbar.txt', + 'blib/lib/auto/share/dist/Simple-Share/subdir/whatever/anotherfoo.txt', + 'blib/lib/auto/share/module/Simple-Share/bar.txt', + ], + "share_dir files copied to blib" +); + +} + +#--------------------------------------------------------------------------# +# test installing +#--------------------------------------------------------------------------# + +my $temp_install = 'temp_install'; +mkdir $temp_install; +ok( -d $temp_install, "temp install dir created" ); + +$mb->install_base($temp_install); +stdout_of( sub { $mb->dispatch('install') } ); + +$share_list = Module::Build->rscan_dir( + "$temp_install/lib/perl5/auto/share", sub {-f} +); + +SKIP: +{ + +skip 'filename case not necessarily preserved', 1 if $^O eq 'VMS'; + +is_deeply( + [ sort @$share_list ], [ + "$temp_install/lib/perl5/auto/share/dist/Simple-Share/foo.txt", + "$temp_install/lib/perl5/auto/share/dist/Simple-Share/subdir/share/anotherbar.txt", + "$temp_install/lib/perl5/auto/share/dist/Simple-Share/subdir/whatever/anotherfoo.txt", + "$temp_install/lib/perl5/auto/share/module/Simple-Share/bar.txt", + ], + "share_dir files correctly installed" +); + +} + +#--------------------------------------------------------------------------# +# test with File::ShareDir +#--------------------------------------------------------------------------# + +SKIP: { + eval { require File::ShareDir; File::ShareDir->VERSION(1.00) }; + skip "needs File::ShareDir 1.00", 2 if $@; + + unshift @INC, File::Spec->catdir($temp_install, qw/lib perl5/); + require Simple::Share; + + eval {File::ShareDir::dist_file('Simple-Share','foo.txt') }; + is( $@, q{}, "Found shared dist file" ); + + eval {File::ShareDir::module_file('Simple::Share','bar.txt') }; + is( $@, q{}, "Found shared module file" ); +} diff --git a/t/resume.t b/t/resume.t new file mode 100644 index 0000000..add123d --- /dev/null +++ b/t/resume.t @@ -0,0 +1,43 @@ +use strict; +use lib 't/lib'; +use MBTest; +plan tests => 3; # or 'no_plan' +use DistGen; + +# Ensure any Module::Build modules are loaded from correct directory +blib_load('Module::Build'); + +# create dist object in a temp directory +# enter the directory and generate the skeleton files +my $dist = DistGen->new->chdir_in; +$dist->add_file('mylib/MBUtil.pm', << "---"); +package MBUtil; +sub foo { 42 } +1; +--- + +$dist->add_file('Build.PL', << "---"); +use strict; +use lib 'mylib'; +use MBUtil; +use Module::Build; + +die unless MBUtil::foo() == 42; + +my \$builder = Module::Build->new( +module_name => '$dist->{name}', +license => 'perl', +); + +\$builder->create_build_script(); +--- + +$dist->regen; + +# get a Module::Build object and test with it +my $mb = $dist->new_from_context(); # quiet by default +isa_ok( $mb, "Module::Build" ); +is( $mb->dist_name, "Simple", "dist_name is 'Simple'" ); +ok( ( grep { /mylib/ } @INC ), "resume added \@INC addition to \@INC"); + +# vim:ts=2:sw=2:et:sta:sts=2 diff --git a/t/runthrough.t b/t/runthrough.t new file mode 100644 index 0000000..1f6730e --- /dev/null +++ b/t/runthrough.t @@ -0,0 +1,201 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest tests => 29; + +blib_load('Module::Build'); +blib_load('Module::Build::ConfigData'); + +######################### + +my $tmp = MBTest->tmpdir; + +use DistGen; +my $dist = DistGen->new(); +$dist->change_build_pl +({ + module_name => 'Simple', + scripts => [ 'script' ], + license => 'perl', + requires => { 'File::Spec' => 0 }, +}); + +$dist->add_file( 'MANIFEST.SKIP', <<'---' ); +^MYMETA.yml$ +--- +$dist->add_file( 'script', <<'---' ); +#!perl -w +print "Hello, World!\n"; +--- +$dist->add_file( 'lib/Simple/Script.PL', <<'---' ); +#!perl -w + +my $filename = shift; +open FH, "> $filename" or die "Can't create $filename: $!"; +print FH "Contents: $filename\n"; +close FH; +--- +$dist->regen; + +$dist->chdir_in; + + +######################### + +my $mb = Module::Build->new_from_context; +ok $mb; +is $mb->license, 'perl'; + +# Make sure cleanup files added before create_build_script() get respected +$mb->add_to_cleanup('before_script'); + +eval {$mb->create_build_script}; +is $@, ''; +ok -e $mb->build_script; + +my $dist_dir = 'Simple-0.01'; + +# VMS in traditional mode needs the $dist_dir name to not have a '.' in it +# as this is a directory delimiter. In extended character set mode the dot +# is permitted for Unix format file specifications. +if ($^O eq 'VMS') { + my $Is_VMS_noefs = 1; + my $vms_efs = 0; + if (eval 'require VMS::Feature') { + $vms_efs = VMS::Feature::current("efs_charset"); + } else { + my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || ''; + $vms_efs = $efs_charset =~ /^[ET1]/i; + } + $Is_VMS_noefs = 0 if $vms_efs; + if ($Is_VMS_noefs) { + $dist_dir = 'Simple-0_01'; + } +} + +is $mb->dist_dir, $dist_dir; + +# The 'cleanup' file doesn't exist yet +ok grep {$_ eq 'before_script'} $mb->cleanup; + +$mb->add_to_cleanup('save_out'); + +# The 'cleanup' file now exists +ok grep {$_ eq 'before_script'} $mb->cleanup; +ok grep {$_ eq 'save_out' } $mb->cleanup; + +{ + # Make sure verbose=>1 works + my $all_ok = 1; + my $output = eval { + stdout_of( sub { $mb->dispatch('test', verbose => 1) } ) + }; + $all_ok &&= is($@, ''); + $all_ok &&= like($output, qr/all tests successful/i); + + # This is the output of lib/Simple/Script.PL + $all_ok &&= ok(-e $mb->localize_file_path('lib/Simple/Script')); + + unless ($all_ok) { + # We use diag() so Test::Harness doesn't get confused. + diag("vvvvvvvvvvvvvvvvvvvvv Simple/t/basic.t output vvvvvvvvvvvvvvvvvvvvv"); + diag($output); + diag("^^^^^^^^^^^^^^^^^^^^^ Simple/t/basic.t output ^^^^^^^^^^^^^^^^^^^^^"); + } +} + +{ + my $output = eval { + stdout_stderr_of( sub { $mb->dispatch('disttest') } ) + }; + is $@, ''; + + # After a test, the distdir should contain a blib/ directory + ok -e File::Spec->catdir('Simple-0.01', 'blib'); + + stdout_stderr_of ( sub { eval {$mb->dispatch('distdir')} } ); + is $@, ''; + + # The 'distdir' should contain a lib/ directory + ok -e File::Spec->catdir('Simple-0.01', 'lib'); + + # The freshly run 'distdir' should never contain a blib/ directory, or + # else it could get into the tarball + ok ! -e File::Spec->catdir('Simple-0.01', 'blib'); + + # Make sure all of the above was done by the new version of Module::Build + open(my $fh, '<', File::Spec->catfile($dist->dirname, 'META.yml')); + my $contents = do {local $/; <$fh>}; + $contents =~ /Module::Build version ([0-9_.]+)/m; + cmp_ok $1, '==', $mb->VERSION, "Check version used to create META.yml: $1 == " . $mb->VERSION; + + SKIP: { + skip( "Archive::Tar 1.08+ not installed", 1 ) + unless eval { require Archive::Tar && Archive::Tar->VERSION(1.08); 1 }; + $mb->add_to_cleanup($mb->dist_dir . ".tar.gz"); + eval {$mb->dispatch('dist')}; + is $@, ''; + } + +} + +{ + # Make sure the 'script' file was recognized as a script. + my $scripts = $mb->script_files; + ok $scripts->{script}; + + # Check that a shebang line is rewritten + my $blib_script = File::Spec->catfile( qw( blib script script ) ); + ok -e $blib_script; + + SKIP: { + skip("We do not rewrite shebang on VMS", 1) if $^O eq 'VMS'; + open(my $fh, '<', $blib_script); + my $first_line = <$fh>; + isnt $first_line, "#!perl -w\n", "should rewrite the shebang line"; + } +} + + +eval {$mb->dispatch('realclean')}; +is $@, ''; + +ok ! -e $mb->build_script; +ok ! -e $mb->config_dir; +ok ! -e $mb->dist_dir; + +SKIP: { + skip( 'Windows-only test', 4 ) unless $^O =~ /^MSWin/; + + my $script_data = <<'---'; +@echo off +echo Hello, World! +--- + + $dist = DistGen->new(); + $dist->change_build_pl({ + module_name => 'Simple', + scripts => [ 'bin/script.bat' ], + license => 'perl', + }); + + $dist->add_file( 'bin/script.bat', $script_data ); + + $dist->regen; + $dist->chdir_in; + + $mb = Module::Build->new_from_context; + ok $mb; + + eval{ $mb->dispatch('build') }; + is $@, ''; + + my $script_file = File::Spec->catfile( qw(blib script), 'script.bat' ); + ok -f $script_file, "Native batch file copied to 'scripts'"; + + my $out = slurp( $script_file ); + is $out, $script_data, ' unmodified by pl2bat'; + +} + diff --git a/t/sample.t b/t/sample.t new file mode 100644 index 0000000..d83bc56 --- /dev/null +++ b/t/sample.t @@ -0,0 +1,20 @@ +# sample.t -- a sample test file for Module::Build + +use strict; +use lib 't/lib'; +use MBTest tests => 2; # or 'no_plan' +use DistGen; + +# Ensure any Module::Build modules are loaded from correct directory +blib_load('Module::Build'); + +# create dist object in a temp directory +# enter the directory and generate the skeleton files +my $dist = DistGen->new->chdir_in->regen; + +# get a Module::Build object and test with it +my $mb = $dist->new_from_context(); # quiet by default +isa_ok( $mb, "Module::Build" ); +is( $mb->dist_name, "Simple", "dist_name is 'Simple'" ); + +# vim:ts=2:sw=2:et:sta:sts=2 diff --git a/t/script_dist.t b/t/script_dist.t new file mode 100644 index 0000000..fa02b49 --- /dev/null +++ b/t/script_dist.t @@ -0,0 +1,79 @@ +#!/usr/bin/perl -w +# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*- +# vim:ts=8:sw=2:et:sta:sts=2 + +use strict; +use lib 't/lib'; +use MBTest 'no_plan'; + +use DistGen qw(undent); +use CPAN::Meta::YAML; + +blib_load('Module::Build'); +blib_load('Module::Build::ConfigData'); + +# XXX DistGen shouldn't be assuming module-ness? +my $dist = DistGen->new(dir => MBTest->tmpdir); +$dist->add_file('bin/foo', undent(<<' ---')); + #!/usr/bin/perl + + package bin::foo; + $VERSION = 0.01; + + =head1 NAME + + foo - does stuff + + =head1 AUTHOR + + A. U. Thor, a.u.thor@a.galaxy.far.far.away + + =cut + + print "hello world\n"; + --- + +my %details = ( + dist_name => 'bin-foo', + dist_version_from => 'bin/foo', + dist_author => ['A. U. Thor, a.u.thor@a.galaxy.far.far.away'], + dist_version => '0.01', +); +my %meta_provides = ( + 'foo' => { + file => 'bin/foo', + version => '0.01', + } +); +$dist->change_build_pl({ + # TODO need to get all of this data out of the program itself + ! $ENV{EXTRA_TEST} ? ( + %details, meta_merge => { provides => \%meta_provides, }, + ) : (), + program_name => 'bin/foo', + license => 'perl', +}); + +# hmm... the old assumption of what a dist looks like is wrong here +$dist->remove_file('lib/Simple.pm'); $dist->regen; + +$dist->chdir_in; +rmdir('lib'); + +#system('konsole'); +my $mb = Module::Build->new_from_context; +ok($mb); +is($mb->program_name, 'bin/foo'); +is($mb->license, 'perl'); +is($mb->dist_name, 'bin-foo'); +is($mb->dist_version, '0.01'); +is_deeply($mb->dist_author, + ['A. U. Thor, a.u.thor@a.galaxy.far.far.away']); +my $result; +stdout_stderr_of( sub { $result = $mb->dispatch('distmeta') } ); +ok $result; + +my $yml = CPAN::Meta::YAML->read_string(slurp('META.yml'))->[0]; +is_deeply($yml->{provides}, \%meta_provides); + +$dist->chdir_original if $dist->did_chdir; diff --git a/t/signature.t b/t/signature.t new file mode 100644 index 0000000..48d97e4 --- /dev/null +++ b/t/signature.t @@ -0,0 +1,100 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest; + +if ( have_module( 'Module::Signature' ) + && $INC{'Module/Signature.pm'} =~ m{t/lib/Module/Signature\.pm} +) { + plan tests => 12; +} else { + plan skip_all => "Mock Module::Signature not loadable"; +} + +blib_load('Module::Build'); + +######################### + +my $tmp = MBTest->tmpdir; + +use DistGen; +my $dist = DistGen->new( dir => $tmp ); +$dist->change_build_pl +({ + module_name => $dist->name, + license => 'perl', + sign => 1, + auto_configure_requires => 0, + quiet => 1, +}); +$dist->regen; + +$dist->chdir_in; + +######################### + +my $mb = Module::Build->new_from_context; + +{ + eval {$mb->dispatch('distdir')}; + my $err = $@; + is $err, ''; + chdir( $mb->dist_dir ) or die "Can't chdir to '@{[$mb->dist_dir]}': $!"; + ok -e 'SIGNATURE'; + + $dist->chdir_in; +} + +{ + # Fake out Module::Signature and Module::Build - the first one to + # run should be distmeta. + my @run_order; + { + local $^W; # Skip 'redefined' warnings + local *Module::Signature::sign; + *Module::Signature::sign = sub { push @run_order, 'sign' }; + local *Module::Build::Base::ACTION_distmeta; + *Module::Build::Base::ACTION_distmeta = sub { push @run_order, 'distmeta' }; + eval { $mb->dispatch('distdir') }; + } + is $@, ''; + is $run_order[0], 'distmeta'; + is $run_order[1], 'sign'; +} + +eval { $mb->dispatch('realclean') }; +is $@, ''; + +{ + eval {$mb->dispatch('distdir', sign => 0 )}; + is $@, ''; + chdir( $mb->dist_dir ) or die "Can't chdir to '@{[$mb->dist_dir]}': $!"; + ok !-e 'SIGNATURE', './Build distdir --sign 0 does not sign'; +} + +eval { $mb->dispatch('realclean') }; +is $@, ''; + +$dist->chdir_in; + +{ + local @ARGV = '--sign=1'; + $dist->change_build_pl({ + module_name => $dist->name, + license => 'perl', + auto_configure_requires => 0, + quiet => 1, + }); + $dist->regen; + + my $mb = Module::Build->new_from_context; + is $mb->{properties}{sign}, 1; + + eval {$mb->dispatch('distdir')}; + my $err = $@; + is $err, ''; + chdir( $mb->dist_dir ) or die "Can't chdir to '@{[$mb->dist_dir]}': $!"; + ok -e 'SIGNATURE', 'Build.PL --sign=1 signs'; +} + diff --git a/t/test_file_exts.t b/t/test_file_exts.t new file mode 100644 index 0000000..5bb803c --- /dev/null +++ b/t/test_file_exts.t @@ -0,0 +1,41 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest tests => 3; +use DistGen; + +blib_load('Module::Build'); + +my $tmp = MBTest->tmpdir; +my $dist = DistGen->new( dir => $tmp ); + +$dist->add_file('t/mytest.s', <<'---' ); +#!perl +use Test::More tests => 2; +ok(1, 'first mytest.s'); +ok(1, 'second mytest.s'); +--- + +$dist->regen; +$dist->chdir_in; + +######################### + +# So make sure that the test gets run with the alternate extension. +ok my $mb = Module::Build->new( + module_name => $dist->name, + test_file_exts => ['.s'], + quiet => 1, +), 'Construct build object with test_file_exts parameter'; + +$mb->add_to_cleanup('save_out'); +# Use uc() so we don't confuse the current test output +my $out = uc(stdout_of( + sub {$mb->dispatch('test', verbose => 1)} +)); + +like $out, qr/^OK 1 - FIRST MYTEST[.]S/m, 'Should see first test output'; +like $out, qr/^OK 2 - SECOND MYTEST[.]S/m, 'Should see second test output'; + +# vim:ts=4:sw=4:et:sta diff --git a/t/test_reqs.t b/t/test_reqs.t new file mode 100644 index 0000000..bd04f86 --- /dev/null +++ b/t/test_reqs.t @@ -0,0 +1,52 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest; +use CPAN::Meta 2.110420; +use CPAN::Meta::YAML; +use Parse::CPAN::Meta 1.4401; +plan tests => 4; + +blib_load('Module::Build'); + +my $tmp = MBTest->tmpdir; + +use DistGen; +my $dist = DistGen->new( dir => $tmp ); +$dist->change_file('Build.PL', <<"---"); +use strict; +use Module::Build; + +my \$builder = Module::Build->new( + module_name => '$dist->{name}', + license => 'perl', + requires => { + 'File::Spec' => 0, + }, + test_requires => { + 'Test::More' => 0, + } +); + +\$builder->create_build_script(); +--- +$dist->regen; +$dist->chdir_in; +$dist->run_build_pl; +my $output = stdout_stderr_of sub { $dist->run_build('distmeta') }; + +for my $file ( qw/MYMETA META/ ) { + my $meta = Parse::CPAN::Meta->load_file($file.".json"); + is_deeply($meta->{prereqs}->{runtime},{ + requires => { + 'File::Spec' => '0', + } + }, "runtime prereqs in $file"); + is_deeply($meta->{prereqs}->{test},{ + requires => { + 'Test::More' => '0', + } + }, "test prereqs in $file"); +} + diff --git a/t/test_type.t b/t/test_type.t new file mode 100644 index 0000000..bdbf0cd --- /dev/null +++ b/t/test_type.t @@ -0,0 +1,74 @@ +#!/usr/bin/perl -w + +BEGIN { + if ($^O eq 'VMS') { + print '1..0 # Child test output confuses harness'; + exit; + } +} + +use strict; +use lib 't/lib'; +use MBTest tests => 7; + +blib_load('Module::Build'); + +my $tmp = MBTest->tmpdir; + +use DistGen; + +my $dist = DistGen->new( dir => $tmp ); + + +$dist->add_file('t/special_ext.st', <<'---' ); +#!perl +use Test::More tests => 2; +ok(1, 'first test in special_ext'); +ok(1, 'second test in special_ext'); +--- + +$dist->regen; + +$dist->chdir_in; + +######################### + +# Here we make sure we can define an action that will test a particular type +$::x = 0; +my $mb = Module::Build->subclass( + code => q# + sub ACTION_testspecial { + $::x++; + shift->generic_test(type => 'special'); + } + # +)->new( + module_name => $dist->name, + test_types => { special => '.st' } +); + +ok $mb; + +$mb->dispatch('testspecial'); +is($::x, 1, "called once"); + + +$mb->add_to_cleanup('save_out'); +# Use uc() so we don't confuse the current test output +my $verbose_output = uc(stdout_of( + sub {$mb->dispatch('testspecial', verbose => 1)} +)); + +like($verbose_output, qr/^OK 1 - FIRST TEST IN SPECIAL_EXT/m); +like($verbose_output, qr/^OK 2 - SECOND TEST IN SPECIAL_EXT/m); + +is( $::x, 2, "called again"); + +my $output = uc(stdout_of( + sub {$mb->dispatch('testspecial', verbose => 0)} +)); +like($output, qr/\.\. ?OK/); + +is($::x, 3, "called a third time"); + +# vim:ts=4:sw=4:et:sta diff --git a/t/test_types.t b/t/test_types.t new file mode 100644 index 0000000..bcb58c4 --- /dev/null +++ b/t/test_types.t @@ -0,0 +1,174 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest tests => 25; + +blib_load('Module::Build'); + +use DistGen; + +my $dist = DistGen->new()->chdir_in; + +$dist->add_file('t/special_ext.st', <<'---'); +#!perl +use Test::More tests => 2; +ok(1, 'first test in special_ext'); +ok(1, 'second test in special_ext'); +--- + +$dist->add_file('t/another_ext.at', <<'---'); +#!perl +use Test::More tests => 2; +ok(1, 'first test in another_ext'); +ok(1, 'second test in another_ext'); +--- +$dist->add_file('t/foo.txt', <<'---'); +#!perl +use Test::More tests => 1; +ok 0, "don't run this non-test file"; +die "don't run this non-test file"; +--- + +$dist->regen; +######################### + +my $mb = Module::Build->subclass( + code => q# + sub ACTION_testspecial { + shift->generic_test(type => 'special'); + } + + sub ACTION_testanother { + shift->generic_test(type => 'another'); + } + # + )->new( + module_name => $dist->name, + test_types => { + special => '.st', + another => '.at', + }, + ); + + +ok $mb; + +my $special_output = uc(stdout_of( + sub {$mb->dispatch('testspecial', verbose => 1)} +)); + +like($special_output, qr/^OK 1 - FIRST TEST IN SPECIAL_EXT/m, + 'saw expected output from first test'); +like($special_output, qr/^OK 2 - SECOND TEST IN SPECIAL_EXT/m, + 'saw expected output from second test'); + +my $another_output = uc(stdout_of( + sub {$mb->dispatch('testanother', verbose => 1)} +)); + +ok($another_output, 'we have some test output'); + +like($another_output, qr/^OK 1 - FIRST TEST IN ANOTHER_EXT/m, + 'saw expected output from first test'); +like($another_output, qr/^OK 2 - SECOND TEST IN ANOTHER_EXT/m, + 'saw expected output from second test'); + + +my $all_output = uc(stdout_of( + sub {$mb->dispatch('testall', verbose => 1)} +)); + +0 and warn "\ntestall said >>>\n$all_output\n<<<\n"; + +like($all_output, qr/^OK 1 - FIRST TEST IN SPECIAL_EXT/m, + 'expected output from basic.t'); +like($all_output, qr/^OK 2 - SECOND TEST IN SPECIAL_EXT/m, + 'expected output from basic.t'); + +like($all_output, qr/^OK 1 - FIRST TEST IN ANOTHER_EXT/m); +like($all_output, qr/^OK 2 - SECOND TEST IN ANOTHER_EXT/m); + +# we get a third one from basic.t +is(scalar(@{[$all_output =~ m/OK 1/mg]}), 3 ); +is(scalar(@{[$all_output =~ m/OK/mg]}), 8 ); +is(scalar(@{[$all_output =~ m/ALL TESTS SUCCESSFUL\./mg]}), 1); + +{ # once-again + +$dist->revert; + +$dist->add_file('t/foo/special.st', <<'---'); +#!perl +use Test::More tests => 2; +ok(1, 'first test in special_ext'); +ok(1, 'second test in special_ext'); +--- +$dist->add_file('t/foo/basic_foo.t', <<'---'); +use Test::More tests => 1; +use strict; use Simple; +ok 1; +--- +$dist->regen; + +my $mb = Module::Build->subclass( + code => q# + sub ACTION_testspecial { + shift->generic_test(type => 'special'); + } + + sub ACTION_testanother { + shift->generic_test(type => 'another'); + } + # + )->new( + recursive_test_files => 1, + module_name => $dist->name, + test_types => { + special => '.st', + another => '.at', + }, + ); + +ok $mb; + +my $special_output = uc(stdout_of( + sub {$mb->dispatch('testspecial', verbose => 1)} +)); + +like($special_output, qr/^OK 1 - FIRST TEST IN SPECIAL_EXT/m, + 'saw expected output from first test'); +like($special_output, qr/^OK 2 - SECOND TEST IN SPECIAL_EXT/m, + 'saw expected output from second test'); + +my $another_output = uc(stdout_of( + sub {$mb->dispatch('testanother', verbose => 1)} +)); + +ok($another_output, 'we have some test output'); + +like($another_output, qr/^OK 1 - FIRST TEST IN ANOTHER_EXT/m, + 'saw expected output from first test'); +like($another_output, qr/^OK 2 - SECOND TEST IN ANOTHER_EXT/m, + 'saw expected output from second test'); + + +my $all_output = uc(stdout_of( + sub {$mb->dispatch('testall', verbose => 1)} +)); + +like($all_output, qr/^OK 1 - FIRST TEST IN SPECIAL_EXT/m, + 'expected output from basic.t'); +like($all_output, qr/^OK 2 - SECOND TEST IN SPECIAL_EXT/m, + 'expected output from basic.t'); + +like($all_output, qr/^OK 1 - FIRST TEST IN ANOTHER_EXT/m); +like($all_output, qr/^OK 2 - SECOND TEST IN ANOTHER_EXT/m); + +# we get a third one from basic.t +is(scalar(@{[$all_output =~ m/(OK 1)/mg]}), 5 ); +is(scalar(@{[$all_output =~ m/(OK)/mg]}), 13 ); + +} # end once-again + +# vim:ts=4:sw=4:et:sta diff --git a/t/tilde.t b/t/tilde.t new file mode 100644 index 0000000..09673f6 --- /dev/null +++ b/t/tilde.t @@ -0,0 +1,114 @@ +#!/usr/bin/perl -w + +# Test ~ expansion from command line arguments. + +use strict; +use lib 't/lib'; +use MBTest tests => 16; + +blib_load('Module::Build'); + +my $tmp = MBTest->tmpdir; + +use DistGen; +my $dist = DistGen->new( dir => $tmp ); +$dist->regen; + +$dist->chdir_in; + + +sub run_sample { + my @args = @_; + + local $Test::Builder::Level = $Test::Builder::Level + 1; + + $dist->clean; + + my $mb; + stdout_of( sub { + $mb = Module::Build->new_from_context( @args ); + } ); + + return $mb; +} + + +my $p = 'install_base'; + +SKIP: { + my $home = $ENV{HOME} ? $ENV{HOME} : undef; + + if ($^O eq 'VMS') { + # Convert the path to UNIX format, trim off the trailing slash + $home = VMS::Filespec::unixify($home); + $home =~ s#/$##; + } + + unless (defined $home) { + my @info = eval { getpwuid $> }; + skip "No home directory for tilde-expansion tests", 15 if $@ + or !defined $info[7]; + $home = $info[7]; + } + + is( run_sample( $p => '~' )->$p(), $home ); + + is( run_sample( $p => '~/fooxzy' )->$p(), "$home/fooxzy" ); + + is( run_sample( $p => '~/ fooxzy')->$p(), "$home/ fooxzy" ); + + is( run_sample( $p => '~/fo o')->$p(), "$home/fo o" ); + + is( run_sample( $p => 'fooxzy~' )->$p(), 'fooxzy~' ); + + is( run_sample( prefix => '~' )->prefix, + $home ); + + # Test when HOME is different from getpwuid(), as in sudo. + { + local $ENV{HOME} = '/wibble/whomp'; + + is( run_sample( $p => '~' )->$p(), "/wibble/whomp" ); + } + + my $mb = run_sample( install_path => { html => '~/html', + lib => '~/lib' } + ); + is( $mb->install_destination('lib'), "$home/lib" ); + # 'html' is translated to 'binhtml' & 'libhtml' + is( $mb->install_destination('binhtml'), "$home/html" ); + is( $mb->install_destination('libhtml'), "$home/html" ); + + $mb = run_sample( install_path => { lib => '~/lib' } ); + is( $mb->install_destination('lib'), "$home/lib" ); + + $mb = run_sample( destdir => '~' ); + is( $mb->destdir, $home ); + + $mb->$p('~'); + is( $mb->$p(), '~', 'API does not expand tildes' ); + + skip "On OS/2 EMX all users are equal", 2 if $^O eq 'os2'; + is( run_sample( $p => '~~' )->$p(), '~~' ); + is( run_sample( $p => '~ fooxzy' )->$p(), '~ fooxzy' ); +} + +# Again, with named users +SKIP: { + my @info = eval { getpwuid $> }; + skip "No home directory for tilde-expansion tests", 1 if $@ + or !defined $info[7] or !defined $info[0]; + my ($me, $home) = @info[0,7]; + + if ($^O eq 'VMS') { + # Convert the path to UNIX format and trim off the trailing slash. + # Also, the fake module we're in has mangled $ENV{HOME} for its own + # purposes; getpwuid doesn't know about that but _detildefy does. + $home = VMS::Filespec::unixify($ENV{HOME}); + $home =~ s#/$##; + } + my $expected = "$home/fooxzy"; + + like( run_sample( $p => "~$me/fooxzy")->$p(), qr(\Q$expected\E)i ); +} + diff --git a/t/unit_run_test_harness.t b/t/unit_run_test_harness.t new file mode 100644 index 0000000..e6a7f53 --- /dev/null +++ b/t/unit_run_test_harness.t @@ -0,0 +1,73 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest tests => 9; + +blib_load('Module::Build'); + +my $tmp = MBTest->tmpdir; + +use DistGen; +my $dist = DistGen->new( dir => $tmp ); +$dist->regen; + +$dist->chdir_in; + +######################### + + +# make sure Test::Harness loaded before we define Test::Harness::runtests otherwise we'll +# get another redefined warning inside Test::Harness::runtests +use Test::Harness; + +{ + package MB::Subclass; + use base qw(Module::Build); + sub harness_switches { return } +} + +{ + local $SIG{__WARN__} = sub { die "Termination after a warning: $_[0]"}; + my $mock1 = { A => 1 }; + my $mock2 = { B => 2 }; + + no warnings qw[redefine once]; + + # This runs run_test_harness with Test::Harness::switches = undef and harness_switches() returning empty list, + # ensure there are no warnings, and output is empty too + { + my $mb = MB::Subclass->new( module_name => $dist->name ); + local *Test::Harness::runtests = sub { + is shift(), $mock1, "runtests ran with expected parameters"; + is shift(), $mock2, "runtests ran with expected parameters"; + is $Test::Harness::switches, '', "switches are undef"; + is $Test::Harness::Switches, '', "switches are undef"; + }; + + # $Test::Harness::switches and $Test::Harness::switches are aliases, but we pretend we don't know this + local $Test::Harness::switches = ''; + local $Test::Harness::switches = ''; + $mb->run_test_harness([$mock1, $mock2]); + + ok 1, "run_test_harness should not produce warning if Test::Harness::[Ss]witches are undef and harness_switches() return empty list"; + } + + # This runs run_test_harness with Test::Harness::switches = '' and harness_switches() returning empty list, + # ensure there are no warnings, and switches are empty string + { + my $mb = MB::Subclass->new( module_name => $dist->name ); + local *Test::Harness::runtests = sub { + is shift(), $mock1, "runtests ran with expected parameters"; + is shift(), $mock2, "runtests ran with expected parameters"; + is $Test::Harness::switches, '', "switches are empty string"; + is $Test::Harness::Switches, '', "switches are empty string"; + }; + + # $Test::Harness::switches and $Test::Harness::switches are aliases, but we pretend we don't know this + local $Test::Harness::switches = ''; + local $Test::Harness::switches = ''; + $mb->run_test_harness([$mock1, $mock2]); + } + +} diff --git a/t/use_tap_harness.t b/t/use_tap_harness.t new file mode 100644 index 0000000..bfce506 --- /dev/null +++ b/t/use_tap_harness.t @@ -0,0 +1,94 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More; +use lib 't/lib'; +if (eval { require TAP::Harness && TAP::Harness->VERSION(3) }) { + plan tests => 9; +} else { + plan skip_all => 'TAP::Harness 3+ not installed' +} + +use MBTest; +use DistGen; + +blib_load('Module::Build'); +my $tmp = MBTest->tmpdir; +my $dist = DistGen->new( dir => $tmp ); +$dist->regen; +$dist->chdir_in; + +######################### + +# Make sure that TAP::Harness properly does its thing. +$dist->change_build_pl( + module_name => $dist->name, + use_tap_harness => 1, + quiet => 1, +); +$dist->regen; + +ok my $mb = $dist->new_from_context, + 'Construct build object with test_file_exts parameter'; + +$mb->add_to_cleanup('save_out'); +# Use uc() so we don't confuse the current test output +my $out = uc(stdout_of( + sub {$mb->dispatch('test', verbose => 1)} +)); + +like $out, qr/^OK 1/m, 'Should see first test output'; +like $out, qr/^ALL TESTS SUCCESSFUL/m, 'Should see test success message'; + +######################### + +# Make sure that arguments are passed through to TAP::Harness. +$dist->change_build_pl( + module_name => $dist->name, + use_tap_harness => 1, + tap_harness_args => { verbosity => 0 }, + quiet => 1, +); +$dist->regen; + +ok $mb = $dist->new_from_context, + 'Construct build object with test_file_exts parameter'; + +$mb->add_to_cleanup('save_out'); +# Use uc() so we don't confuse the current test output +$out = uc(stdout_of( + sub {$mb->dispatch('test', verbose => 1)} +)); + +unlike $out, qr/^OK 1/m, 'Should not see first test output'; +like $out, qr/^ALL TESTS SUCCESSFUL/m, 'Should see test success message'; + +#--------------------------------------------------------------------------# +# test that a failing test dies +#--------------------------------------------------------------------------# + +$dist->change_build_pl( + module_name => $dist->name, + use_tap_harness => 1, + tap_harness_args => { verbosity => 1 }, + quiet => 1, +); +$dist->change_file('t/basic.t',<<"---"); +use Test::More tests => 1; +use strict; + +use $dist->{name}; +ok 0; +--- +$dist->regen; + +ok $mb = $dist->new_from_context, + 'Construct build object after setting tests to fail'; +# Use uc() so we don't confuse the current test output +$out = stdout_stderr_of( sub { $dist->run_build('test')} ); +ok( $?, "'Build test' had non-zero exit code" ); +like( $out, qr{Errors in testing\. Cannot continue\.}, + "Saw emulated Test::Harness die() message" +); + +# vim:ts=4:sw=4:et:sta diff --git a/t/versions.t b/t/versions.t new file mode 100644 index 0000000..5eafbac --- /dev/null +++ b/t/versions.t @@ -0,0 +1,21 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest tests => 2; + +blib_load('Module::Build'); + +my $tmp = MBTest->tmpdir; + +use DistGen; +my $dist = DistGen->new( dir => $tmp ); +$dist->regen; + +######################### + +my @mod = split( /::/, $dist->name ); +my $file = File::Spec->catfile( $dist->dirname, 'lib', @mod ) . '.pm'; +is( Module::Build->version_from_file( $file ), '0.01', 'version_from_file' ); + +ok( Module::Build->compare_versions( '1.01_01', '>', '1.01' ), 'compare: 1.0_01 > 1.0' ); diff --git a/t/write_default_maniskip.t b/t/write_default_maniskip.t new file mode 100644 index 0000000..40389f2 --- /dev/null +++ b/t/write_default_maniskip.t @@ -0,0 +1,42 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use lib 't/lib'; +use MBTest 'no_plan'; +use DistGen; +use Cwd; + +blib_load('Module::Build'); + +{ + my $cwd = Cwd::cwd; + chdir MBTest->tmpdir(); + + my $build = Module::Build->new( + module_name => "Foo::Bar", + dist_name => "Foo-Bar", + dist_version => '1.23', + ); + + my $skip = "mskip.txt"; # for compatibility + $build->_write_default_maniskip($skip); + + ok -r $skip, "Default maniskip written"; + my $have = slurp($skip); + + my $head; + if( $build->_eumanifest_has_include ) { + $head = "#!include_default\n"; + } + else { + $head = slurp($build->_default_maniskip); + } + + like $have, qr/^\Q$head\E/, "default MANIFEST.SKIP used"; + like $have, qr/^# Avoid Module::Build generated /ms, "Module::Build specific entries"; + like $have, qr/Foo-Bar-/, "distribution tarball entry"; + + DistGen::chdir_all($cwd); +} @@ -0,0 +1,217 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest; +use Config; + +my $tmp; + +blib_load('Module::Build'); + +{ + my ($have_c_compiler, $tmp_exec) = check_compiler(); + + if ( !$have_c_compiler ) { + plan skip_all => 'No compiler found'; + } elsif ( $^O eq 'VMS' ) { + plan skip_all => 'Child test output confuses harness'; + } elsif ( !$Config{usedl} ) { + plan skip_all => 'Perl not compiled for dynamic loading' + } else { + plan tests => 22; + } + require Cwd; + $tmp = MBTest->tmpdir( $tmp_exec ? () : (DIR => Cwd::cwd) ); +} + + + +######################### + +use DistGen; +my $dist = DistGen->new( dir => $tmp, xs => 1 )->chdir_in->regen; + +my $mb = $dist->new_from_context; + +eval {$mb->dispatch('clean')}; +is $@, ''; + +eval {$mb->dispatch('build')}; +is $@, ''; + +{ + # Make sure it actually works: that we can call methods in the XS module + + # Unfortunately, We must do this is a subprocess because some OS will not + # release the handle on a dynamic lib until the attaching process terminates + + ok $mb->run_perl_command(['-Mblib', '-M'.$dist->name, '-e1']); + + like stdout_of( sub {$mb->run_perl_command([ + '-Mblib', '-M'.$dist->name, + '-we', "print @{[$dist->name]}::okay()"])}), qr/ok$/; + + like stdout_of( sub {$mb->run_perl_command([ + '-Mblib', '-M'.$dist->name, + '-we', "print @{[$dist->name]}::version()"])}), qr/0.01$/; + + like stdout_of( sub {$mb->run_perl_command([ + '-Mblib', '-M'.$dist->name, + '-we', "print @{[$dist->name]}::xs_version()"])}), qr/0.01$/; + +} + +{ + # Try again in a subprocess + eval {$mb->dispatch('clean')}; + is $@, ''; + + + $mb->create_build_script; + my $script = $mb->build_script; + ok -e $script; + + eval {$mb->run_perl_script($script)}; + is $@, ''; +} + +# We can't be verbose in the sub-test, because Test::Harness will +# think that the output is for the top-level test. +stdout_stderr_of( sub { eval {$mb->dispatch('test')} }); +is $@, ''; + +eval {$mb->dispatch('clean')}; +is $@, ''; + + +SKIP: { + skip( "skipping a Unixish-only tests", 1 ) + unless $mb->is_unixish; + + $mb->{config}->push(ld => "FOO=BAR ".$mb->config('ld')); + eval {$mb->dispatch('build')}; + is $@, ''; + $mb->{config}->pop('ld'); +} + +eval {$mb->dispatch('realclean')}; +is $@, ''; + +# Make sure blib/ is gone after 'realclean' +ok ! -e 'blib'; + +######################################## + +# Try a XS distro with a deep namespace + + +$dist->reset( name => 'Simple::With::Deep::Name', dir => $tmp, xs => 1 ); +$dist->chdir_in->regen; + +$mb = $dist->new_from_context; + +eval { $mb->dispatch('build') }; +is $@, ''; + +stdout_stderr_of( sub { eval { $mb->dispatch('test') } } ); +is $@, ''; + +eval { $mb->dispatch('clean') }; + +eval { $mb->dispatch('build', 'pureperl_only' => 1) }; +like $@, qr/\ACan\'t build xs files under --pureperl-only/, 'Can\'t build xs under pureperl'; + +eval { $mb->dispatch('build', pureperl_only => 1, allow_pureperl => 1) }; +is $@, '', 'Can\'t build xs under pureperl, unless allow_pureperl'; + +eval { $mb->dispatch('realclean') }; +is $@, ''; + +######################################## + +# Try a XS distro using a flat directory structure +# and a 'dist_name' instead of a 'module_name' + +$dist->reset( name => 'Dist-Name', dir => $tmp, xs => 1 )->chdir_in; + +$dist->remove_file('lib/Dist-Name.pm'); +$dist->remove_file('lib/Dist-Name.xs'); + +$dist->change_build_pl + ({ + dist_name => 'Dist-Name', + dist_version_from => 'Simple.pm', + pm_files => { 'Simple.pm' => 'lib/Simple.pm' }, + xs_files => { 'Simple.xs' => 'lib/Simple.xs' }, + }); + +$dist->add_file('Simple.xs', <<"---"); +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +MODULE = Simple PACKAGE = Simple + +SV * +okay() + CODE: + RETVAL = newSVpv( "ok", 0 ); + OUTPUT: + RETVAL +--- + +$dist->add_file( 'Simple.pm', <<"---" ); +package Simple; + +\$VERSION = '0.01'; + +require Exporter; +require DynaLoader; + +\@ISA = qw( Exporter DynaLoader ); +\@EXPORT_OK = qw( okay ); + +bootstrap Simple \$VERSION; + +1; + +__END__ + +=head1 NAME + +Simple - Perl extension for blah blah blah + +=head1 DESCRIPTION + +Stub documentation for Simple. + +=head1 AUTHOR + +A. U. Thor, a.u.thor\@a.galaxy.far.far.away + +=cut +--- +$dist->change_file('t/basic.t', <<"---"); +use Test::More tests => 2; +use strict; + +use Simple; +ok( 1 ); + +ok( Simple::okay() eq 'ok' ); +--- + +$dist->regen; + +$mb = $dist->new_from_context; + +eval { $mb->dispatch('build') }; +is $@, ''; + +stdout_of( sub { eval { $mb->dispatch('test') } } ); +is $@, ''; + +eval { $mb->dispatch('realclean') }; +is $@, ''; + |