view release on metacpan or  search on metacpan

local/lib/perl5/Module/Build/Base.pm  view on Meta::CPAN

  }
  else {
    $self->log_info("No tests defined.\n");
  }

  $self->run_visual_script;
}

sub run_tap_harness {
  my ($self, $tests) = @_;

  require TAP::Harness::Env;

  # TODO allow the test @INC to be set via our API?

  my $aggregate = TAP::Harness::Env->create({
    lib => [@INC],
    verbosity => $self->{properties}{verbose},
    switches  => [ $self->harness_switches ],
    %{ $self->tap_harness_args },
  })->runtests(@$tests);

  return $aggregate;
}

sub run_test_harness {
    my ($self, $tests) = @_;
    require Test::Harness;

    local $Test::Harness::verbose = $self->verbose || 0;
    local $Test::Harness::switches = join ' ', $self->harness_switches;

    Test::Harness::runtests(@$tests);
}

sub run_visual_script {
    my $self = shift;
    # This will get run and the user will see the output.  It doesn't
    # emit Test::Harness-style output.
    $self->run_perl_script('visual.pl', '-Mblib='.$self->blib)
        if -e 'visual.pl';
}

sub harness_switches {
    my $self = shift;
    my @res;
    push @res, qw(-w -d) if $self->{properties}{debugger};
    push @res, '-MDevel::Cover' if $self->{properties}{cover};
    return @res;
}

sub test_files {
  my $self = shift;
  my $p = $self->{properties};
  if (@_) {
    return $p->{test_files} = (@_ == 1 ? shift : [@_]);
  }
  return $self->find_test_files;
}

sub expand_test_dir {
  my ($self, $dir) = @_;
  my $exts = $self->{properties}{test_file_exts};

  return sort map { @{$self->rscan_dir($dir, qr{^[^.].*\Q$_\E$})} } @$exts
    if $self->recursive_test_files;

  return sort map { glob File::Spec->catfile($dir, "*$_") } @$exts;
}

sub ACTION_testdb {
  my ($self) = @_;
  local $self->{properties}{debugger} = 1;
  $self->depends_on('test');
}

sub ACTION_testcover {
  my ($self) = @_;

  unless (Module::Metadata->find_module_by_name('Devel::Cover')) {
    warn("Cannot run testcover action unless Devel::Cover is installed.\n");
    return;
  }

  $self->add_to_cleanup('coverage', 'cover_db');
  $self->depends_on('code');

  # See whether any of the *.pm files have changed since last time
  # testcover was run.  If so, start over.
  if (-e 'cover_db') {
    my $pm_files = $self->rscan_dir
        (File::Spec->catdir($self->blib, 'lib'), $self->file_qr('\.pm$') );
    my $cover_files = $self->rscan_dir('cover_db', sub {-f $_ and not /\.html$/});

    $self->do_system(qw(cover -delete))
      unless $self->up_to_date($pm_files,         $cover_files)
          && $self->up_to_date($self->test_files, $cover_files);
  }

  local $self->{properties}{cover} = 1;
  $self->depends_on('test');
  $self->do_system('cover');
}

sub ACTION_code {
  my ($self) = @_;

  # All installable stuff gets created in blib/ .
  # Create blib/arch to keep blib.pm happy
  my $blib = $self->blib;
  $self->add_to_cleanup($blib);
  File::Path::mkpath( File::Spec->catdir($blib, 'arch') );

  if (my $split = $self->autosplit) {
    $self->autosplit_file($_, $blib) for ref($split) ? @$split : ($split);
  }

  foreach my $element (@{$self->build_elements}) {
    my $method = "process_${element}_files";
    $method = "process_files_by_extension" unless $self->can($method);
    $self->$method($element);

local/lib/perl5/Module/Build/Base.pm  view on Meta::CPAN

  foreach my $file (sort keys %$files) {
    my $result = $self->copy_if_modified($file, $script_dir, 'flatten') or next;
    $self->fix_shebang_line($result) unless $self->is_vmsish;
    $self->make_executable($result);
  }
}

sub find_PL_files {
  my $self = shift;
  if (my $files = $self->{properties}{PL_files}) {
    # 'PL_files' is given as a Unix file spec, so we localize_file_path().

    if (ref $files eq 'ARRAY') {
      return { map {$_, [/^(.*)\.PL$/]}
               map $self->localize_file_path($_),
               @$files };

    } elsif (ref $files eq 'HASH') {
      my %out;
      while (my ($file, $to) = each %$files) {
        $out{ $self->localize_file_path($file) } = [ map $self->localize_file_path($_),
                                                     ref $to ? @$to : ($to) ];
      }
      return \%out;

    } else {
      die "'PL_files' must be a hash reference or array reference";
    }
  }

  return unless -d 'lib';
  return {
    map {$_, [/^(.*)\.PL$/i ]}
    @{ $self->rscan_dir('lib', $self->file_qr('\.PL$')) }
  };
}

sub find_pm_files  { shift->_find_file_by_type('pm',  'lib') }
sub find_pod_files { shift->_find_file_by_type('pod', 'lib') }
sub find_xs_files  { shift->_find_file_by_type('xs',  'lib') }

sub find_script_files {
  my $self = shift;
  if (my $files = $self->script_files) {
    # Always given as a Unix file spec.  Values in the hash are
    # meaningless, but we preserve if present.
    return { map {$self->localize_file_path($_), $files->{$_}} keys %$files };
  }

  # No default location for script files
  return {};
}

sub find_test_files {
  my $self = shift;
  my $p = $self->{properties};

  if (my $files = $p->{test_files}) {
    $files = [sort keys %$files] if ref $files eq 'HASH';
    $files = [map { -d $_ ? $self->expand_test_dir($_) : $_ }
              map glob,
              $self->split_like_shell($files)];

    # Always given as a Unix file spec.
    return [ map $self->localize_file_path($_), @$files ];

  } else {
    # Find all possible tests in t/ or test.pl
    my @tests;
    push @tests, 'test.pl'                          if -e 'test.pl';
    push @tests, $self->expand_test_dir('t')        if -e 't' and -d _;
    return \@tests;
  }
}

sub _find_file_by_type {
  my ($self, $type, $dir) = @_;

  if (my $files = $self->{properties}{"${type}_files"}) {
    # Always given as a Unix file spec
    return { map $self->localize_file_path($_), %$files };
  }

  return {} unless -d $dir;
  return { map {$_, $_}
           map $self->localize_file_path($_),
           grep !/\.\#/,
           @{ $self->rscan_dir($dir, $self->file_qr("\\.$type\$")) } };
}

sub localize_file_path {
  my ($self, $path) = @_;
  return File::Spec->catfile( split m{/}, $path );
}

sub localize_dir_path {
  my ($self, $path) = @_;
  return File::Spec->catdir( split m{/}, $path );
}

sub fix_shebang_line { # Adapted from fixin() in ExtUtils::MM_Unix 1.35
  my ($self, @files) = @_;
  my $c = ref($self) ? $self->{config} : 'Module::Build::Config';

  my ($does_shbang) = $c->get('sharpbang') =~ /^\s*\#\!/;
  for my $file (@files) {
    open(my $FIXIN, '<', $file) or die "Can't process '$file': $!";
    local $/ = "\n";
    chomp(my $line = <$FIXIN>);
    next unless $line =~ s/^\s*\#!\s*//;     # Not a shebang file.

    my ($cmd, $arg) = (split(' ', $line, 2), '');
    next unless $cmd =~ /perl/i;
    my $interpreter = $self->{properties}{perl};

    $self->log_verbose("Changing sharpbang in $file to $interpreter\n");
    my $shb = '';
    $shb .= $c->get('sharpbang')."$interpreter $arg\n" if $does_shbang;

    open(my $FIXOUT, '>', "$file.new")
      or die "Can't create new $file: $!\n";

    # Print out the new #! line (or equivalent).
    local $\;
    undef $/; # Was localized above
    print $FIXOUT $shb, <$FIXIN>;
    close $FIXIN;
    close $FIXOUT;

    rename($file, "$file.bak")
      or die "Can't rename $file to $file.bak: $!";