path: root/lib/Module/Build/t/compat.t

#!/usr/bin/perl -w

use strict;
use lib $ENV{PERL_CORE} ? '../lib/Module/Build/t/lib' : 't/lib';
use MBTest;
use File::Spec;
use IO::File;
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);

use_ok 'Module::Build';
ensure_blib('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;


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

use Module::Build;
use 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,
  },
  build_requires      => {
    'Test::More'  => 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,
        'Test::More' => 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_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_of( sub {
    $foo_builder = Foo::Builder->new_from_context;
  });
  foreach my $style ('passthrough', 'small') {
    Module::Build::Compat->create_makefile_pl($style, $foo_builder);
    ok -e 'Makefile.PL', "$style Makefile.PL created";
    
    # 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_of( sub {
    $bar_builder = Module::Build->subclass( class => 'Bar::Builder' )->new_from_context;
  });
  foreach my $style ('passthrough', 'small') {
    Module::Build::Compat->create_makefile_pl($style, $bar_builder);
    ok -e 'Makefile.PL', "$style Makefile.PL created via subclass";
    my $result;
    stdout_of( sub {
      $result = $mb->run_perl_script('Makefile.PL');
    });
    ok $result, "Makefile.PL ran without error";
  }
}

{
  # Make sure various Makefile.PL arguments are supported
  Module::Build::Compat->create_makefile_pl('passthrough', $mb);

  my $libdir = File::Spec->catdir( $tmp, 'libdir' );
  my $result;
  stdout_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_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_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/;

  SKIP: {
    require ExtUtils::Install;
    skip "Needs ExtUtils::Install 1.32 or later", 2
      if ExtUtils::Install->VERSION < 1.32;

    my @make_args = ('INSTALLDIRS=vendor', "INSTALLVENDORLIB=$libdir2");

    if ($is_vms_mms) { # VMS MMK/MMS macros use different syntax.
      $make_args[0] = '/macro=("' . join('","',@make_args) . '")';
      pop @make_args while scalar(@make_args) > 1;
    }

    ($output) = stdout_stderr_of(
      sub {
        $ran_ok = $mb->do_system(@make, 'fakeinstall', @make_args);
      }
    );

    ok $ran_ok, "make fakeinstall with INSTALLDIRS=vendor ran ok";
    $output =~ s/^/# /gm;  # Don't confuse our own test output
    like $output,
        qr/\Q$libdir2\E .* Simple\.pm/ix,
        'Should have installdirs=vendor';
  }

  stdout_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} );

  Module::Build::Compat->create_makefile_pl('passthrough', $mb);

  stdout_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_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";
}

# cleanup
$dist->remove;

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

sub test_makefile_types {
  my %opts = @_;
  $opts{requires} ||= {};
  $opts{PL_files} ||= {};

  foreach my $type (@makefile_types) {
    # Create M::B instance 
    my $mb;
    stdout_of( sub {
        $mb = Module::Build->new_from_context;
    });
    ok $mb, "Module::Build->new_from_context";

    # Create and test Makefile.PL
    Module::Build::Compat->create_makefile_pl($type, $mb);
    ok -e 'Makefile.PL', "$type Makefile.PL created";
    test_makefile_pl_requires_perl( $opts{requires}{perl} );
    test_makefile_creation($mb);
    test_makefile_prereq_pm( $opts{requires} );
    test_makefile_pl_files( $opts{PL_files} ) if $type eq 'traditional';
      
    my ($output,$success);
    # Capture output to keep our STDOUT clean
    $output = stdout_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_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_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', 1);
    
    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_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) {
    $output = stdout_of( sub {
      $build->do_system(@make, 'realclean');
    });
    ok ! -e '$makefile', "$makefile cleaned up";
  }
  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 "$makefile not found", 1 unless -e $makefile;
    my $pl_files = find_params_in_makefile()->{PL_FILES} || {};
    is_deeply $pl_files, $expected,
      "$makefile has correct PL_FILES line";
  }
}

sub test_makefile_pl_requires_perl {
  my $perl_version = shift || q{};
  SKIP: {
    skip 'Makefile.PL not found', 1 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 {
  my $fh = IO::File->new( $makefile, 'r' ) 
    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;
}