File Coverage

lib/Perl/PrereqScanner/NotQuiteLite/App.pm

Criterion	Covered	Total	%
statement	261	338	77.2
branch	119	202	58.9
condition	38	80	47.5
subroutine	25	31	80.6
pod	3	3	100.0
total	446	654	68.2

package Perl::PrereqScanner::NotQuiteLite::App;

use strict;
use warnings;
use File::Find;
use File::Glob 'bsd_glob';
use File::Basename;
use File::Spec;
use CPAN::Meta::Prereqs;
use CPAN::Meta::Requirements;
use Perl::PrereqScanner::NotQuiteLite;
use Perl::PrereqScanner::NotQuiteLite::Util::Prereqs;
use Parse::Distname;

use constant WIN32 => $^O eq 'MSWin32';

my %IsTestClassFamily = map {$_ => 1} qw(
  Test::Class
  Test::Class::Moose
  Test::Class::Most
  Test::Class::Sugar
  Test::Classy
);

sub new {
  my ($class, %opts) = @_;

  for my $key (keys %opts) {
    next unless $key =~ /\-/;
    (my $replaced_key = $key) =~ s/\-/_/g;
    $opts{$replaced_key} = $opts{$key};
  }

  $opts{prereqs} = CPAN::Meta::Prereqs->new;
  $opts{parsers} = [':bundled'] unless defined $opts{parsers};
  $opts{recommends} = 0 unless defined $opts{recommends};
  $opts{suggests} = 0 unless defined $opts{suggests};
  $opts{base_dir} ||= File::Spec->curdir;

  $opts{cpanfile} = 1 if $opts{save_cpanfile};

  if ($opts{features} and ref $opts{features} ne 'HASH') {
    my @features;
    if (!ref $opts{features}) {
      @features = split ';', $opts{features};
    } elsif (ref $opts{features} eq 'ARRAY') {
      @features = @{$opts{features}};
    }
    my %map;
    for my $spec (@features) {
      my ($identifier, $description, $paths) = split ':', $spec;
      my @paths = map { bsd_glob(File::Spec->catdir($opts{base_dir}, $_)) } split ',', $paths;
      if (WIN32) {
          s|\\|/|g for @paths;
      }
      $map{$identifier} = {
        description => $description,
        paths => \@paths,
      };
    }
    $opts{features} = \%map;
  }

  if ($opts{ignore} and ref $opts{ignore} eq 'ARRAY') {
    require Regexp::Trie;
    my $re = Regexp::Trie->new;
    for (@{$opts{ignore}}) {
        s|\\|/|g if WIN32;
        $re->add($_);
    }
    $opts{ignore_re} ||= $re->_regexp;
  }

  if ($opts{private} and ref $opts{private} eq 'ARRAY') {
    require Regexp::Trie;
    my $re = Regexp::Trie->new;
    for (@{$opts{private}}) {
        $re->add($_);
    }
    $opts{private_re} ||= $re->_regexp;
  }

  if ($opts{optional} and ref $opts{optional} eq 'ARRAY') {
    require Regexp::Trie;
    my $re = Regexp::Trie->new;
    for (@{$opts{optional}}) {
        s|\\|/|g if WIN32;
        $re->add($_);
    }
    $opts{optional_re} ||= $re->_regexp;
  }
  if ($opts{optional_re}) {
    $opts{suggests} = 1;
  }

  if (my $index_name = delete $opts{use_index}) {
    my $index_package = "CPAN::Common::Index::$index_name";
    if (eval "require $index_package; 1") {
      $opts{index} = $index_package->new;
    }
  }

  if ($opts{scan_also}) {
    $opts{libs} ||= delete $opts{scan_also};
  }

  bless \%opts, $class;
}

sub run {
  my ($self, @args) = @_;

  unless (@args) {
    # for configure requires
    push @args, "Makefile.PL", "Build.PL";

    # for test requires
    push @args, "t";

    # for runtime requires;
    if ($self->{blib} and -d File::Spec->catdir($self->{base_dir}, 'blib')) {
      push @args, "blib/lib", "blib/bin", "blib/script";
    } else {
      push @args, "lib";
      push @args, glob(File::Spec->catfile($self->{base_dir}, '*.pm'));
      push @args, "bin", "script", "scripts";
    }

    # extra libs
    push @args, map { bsd_glob(File::Spec->catdir($self->{base_dir}, $_)) } @{$self->{libs} || []};

    # for develop requires
    push @args, "xt", "author" if $self->{develop};
  }

  if ($self->{verbose}) {
    print STDERR "Scanning the following files/directories\n";
    print STDERR "  $_\n" for sort @args;
  }

  for my $path (@args) {
    my $item = File::Spec->file_name_is_absolute($path) ? $path : File::Spec->catfile($self->{base_dir}, $path);
    -d $item ? $self->_scan_dir($item) :
    -f $item ? $self->_scan_file($item) :
    next;
  }

  # add test requirements by .pm files used in .t files
  $self->_add_test_requires($self->{allow_test_pms});

  $self->_exclude_local_modules;

  if ($self->{exclude_core}) {
    $self->_exclude_core_prereqs;
  }

  if ($self->{index}) {
    $self->_dedupe_indexed_prereqs;
  }

  $self->_dedupe;

  if ($self->{print} or $self->{cpanfile}) {
    if ($self->{json}) {
      # TODO: feature support (how should we express it?)
      eval { require JSON::PP } or die "requires JSON::PP";
      print JSON::PP->new->pretty(1)->canonical->encode($self->{prereqs}->as_string_hash);
    } elsif ($self->{cpanfile}) {
      eval { require Perl::PrereqScanner::NotQuiteLite::Util::CPANfile } or die "requires Module::CPANfile";
      my $file = File::Spec->catfile($self->{base_dir}, "cpanfile");
      my $cpanfile = Perl::PrereqScanner::NotQuiteLite::Util::CPANfile->load_and_merge($file, $self->{prereqs}, $self->{features});

      $self->_dedupe_indexed_prereqs($cpanfile->prereqs) if $self->{index};

      if ($self->{save_cpanfile}) {
        $cpanfile->save($file);
      } elsif ($self->{print}) {
        print $cpanfile->to_string, "\n";
      }
      return $cpanfile;
    } elsif ($self->{print}) {
      $self->_print_prereqs;
    }
  }
  $self->{prereqs};
}

sub index { shift->{index} }

sub _print_prereqs {
  my $self = shift;

  my $combined = CPAN::Meta::Requirements->new;

  for my $req ($self->_requirements) {
    $combined->add_requirements($req);
  }
  my $hash = $combined->as_string_hash;
  for my $module (sort keys %$hash) {
    next if $module eq 'perl';
    my $version = $hash->{$module} || 0;
    $version = qq{"$version"} unless $version =~ /^[0-9]+(?:\.[0-9]+)?$/;
    print $version eq '0' ? "$module\n" : "$module~$version\n";
  }
}

sub _requirements {
  my ($self, $prereqs) = @_;

  $prereqs ||= $self->{prereqs};
  my @phases = qw/configure runtime build test/;
  push @phases, 'develop' if $self->{develop};
  my @types = $self->{suggests} ? qw/requires recommends suggests/ : $self->{recommends} ? qw/requires recommends/ : qw/requires/;
  my @requirements;
  for my $phase (@phases) {
    for my $type (@types) {
      my $req = $prereqs->requirements_for($phase, $type);
      next unless $req->required_modules;
      push @requirements, $req;
    }
  }

  if ($self->{features}) {
    my @feature_prereqs = grep defined, map {$self->{features}{$_}{prereqs}} keys %{$self->{features} || {}};
    for my $feature_prereqs (@feature_prereqs) {
      for my $phase (@phases) {
        for my $type (@types) {
          my $req = $feature_prereqs->requirements_for($phase, $type);
          next unless $req->required_modules;
          push @requirements, $req;
        }
      }
    }
  }

  @requirements;
}

sub _exclude_local_modules {
  my $self = shift;

  my @local_dirs = ("inc", @{$self->{libs} || []});
  for my $dir (@local_dirs) {
    my $local_dir = File::Spec->catdir($self->{base_dir}, $dir);
    next unless -d $local_dir;
    find({
      wanted => sub {
        my $file = $_;
        return unless -f $file;
        my $relpath = File::Spec->abs2rel($file, $local_dir);

        return unless $relpath =~ /\.pm$/;
        my $module = $relpath;
        $module =~ s!\.pm$!!;
        $module =~ s![\\/]!::!g;
        $self->{possible_modules}{$module} = 1;
        $self->{possible_modules}{"inc::$module"} = 1 if $dir eq 'inc';
      },
      no_chdir => 1,
    }, $local_dir);
  }

  my $private_re = $self->{private_re};
  for my $req ($self->_requirements) {
    for my $module ($req->required_modules) {
      next unless $self->{possible_modules}{$module} or ($private_re and $module =~ /$private_re/);
      $req->clear_requirement($module);
      if ($self->{verbose}) {
        print STDERR "  excluded $module (local)\n";
      }
    }
  }
}

sub _exclude_core_prereqs {
  my $self = shift;

  eval { require Module::CoreList; Module::CoreList->VERSION('2.99') } or die "requires Module::CoreList 2.99";

  my $perl_version = $self->{perl_version} || $self->_find_used_perl_version || '5.008001';
  if ($perl_version =~ /^v?5\.(0?[1-9][0-9]?)(?:\.([0-9]))?$/) {
    $perl_version = sprintf '5.%03d%03d', $1, $2 || 0;
  }
  $perl_version = '5.008001' unless exists $Module::CoreList::version{$perl_version};

  my %core_alias = (
    'Getopt::Long::Parser'   => 'Getopt::Long',
    'Tie::File::Cache'       => 'Tie::File',
    'Tie::File::Heap'        => 'Tie::File',
    'Tie::StdScalar'         => 'Tie::Scalar',
    'Tie::StdArray'          => 'Tie::Array',
    'Tie::StdHash'           => 'Tie::Hash',
    'Tie::ExtraHash'         => 'Tie::Hash',
    'Tie::RefHash::Nestable' => 'Tie::RefHash',
  );

  for my $req ($self->_requirements) {
    for my $module ($req->required_modules) {
      $module = $core_alias{$module} if exists $core_alias{$module};
      if (Module::CoreList::is_core($module, undef, $perl_version) and
          !Module::CoreList::deprecated_in($module, undef, $perl_version)
      ) {
        next unless exists $Module::CoreList::version{$perl_version}{$module};
        my $core_version = $Module::CoreList::version{$perl_version}{$module};
        next unless $req->accepts_module($module => $core_version);
        $req->clear_requirement($module);
        if ($self->{verbose}) {
          print STDERR "  excluded $module ($perl_version core)\n";
        }
      }
    }
  }
}

sub _find_used_perl_version {
  my $self = shift;
  my @perl_versions;
  my $perl_requirements = CPAN::Meta::Requirements->new;
  for my $req ($self->_requirements) {
    my $perl_req = $req->requirements_for_module('perl');
    $perl_requirements->add_string_requirement('perl', $perl_req) if $perl_req;
  }
  return $perl_requirements->is_simple ? $perl_requirements->requirements_for_module('perl') : undef;
}

sub _add_test_requires {
  my ($self, $force) = @_;

  if (my $test_reqs = $self->{prereqs}->requirements_for('test', 'requires')) {
    my @required_modules = $test_reqs->required_modules;
    for my $module (@required_modules) {
      $force = 1 if exists $IsTestClassFamily{$module};
      my $relpath = $self->{possible_modules}{$module} or next;
      my $context = delete $self->{_test_pm}{$relpath} or next;
      $test_reqs->add_requirements($context->requires);
      if ($self->{recommends} or $self->{suggests}) {
        $self->{prereqs}->requirements_for('test', 'recommends')->add_requirements($context->recommends);
      }
      if ($self->{suggests}) {
        $self->{prereqs}->requirements_for('test', 'suggests')->add_requirements($context->suggests);
      }
    }
    if ($force) {
      for my $context (values %{$self->{_test_pm} || {}}) {
        $test_reqs->add_requirements($context->requires);
        if ($self->{recommends} or $self->{suggests}) {
          $self->{prereqs}->requirements_for('test', 'recommends')->add_requirements($context->recommends);
        }
        if ($self->{suggests}) {
          $self->{prereqs}->requirements_for('test', 'suggests')->add_requirements($context->suggests);
        }
      }
    }
  }
}

sub _dedupe {
  my $self = shift;

  my $prereqs = $self->{prereqs};

  my %features = map {$_ => $self->{features}{$_}{prereqs}} keys %{$self->{features} || {}};

  dedupe_prereqs_and_features($prereqs, \%features);
}

sub _get_uri {
  my ($self, $module) = @_;
  $self->{uri_cache}{$module} ||= $self->__get_uri($module);
}

sub __get_uri {
  my ($self, $module) = @_;
  my $res = $self->{index}->search_packages({ package => $module }) or return;
  ## ignore (non-dual) core modules
  return if _dist_from_uri($res->{uri}) eq 'perl';
  return $res->{uri};
}

sub _dist_from_uri {
  my $uri = shift;
  $uri =~ s!^cpan:///\w+/!!;
  Parse::Distname->new($uri)->dist;
}

sub _dedupe_indexed_prereqs {
  my ($self, $prereqs) = @_;

  for my $req ($self->_requirements($prereqs)) {
    my %uri_map;
    for my $module ($req->required_modules) {
      next if $module eq 'perl';
      my $uri = $self->_get_uri($module) or next;
      $uri_map{$uri}{$module} = $req->requirements_for_module($module);
    }
    for my $uri (keys %uri_map) {
      my @modules = keys %{$uri_map{$uri}};
      next if @modules < 2;

      my @modules_without_version = grep {!$uri_map{$uri}{$_}} @modules;
      next unless @modules_without_version;

      # clear unversioned prereqs if a versioned prereq exists
      if (@modules > @modules_without_version) {
        $req->clear_requirement($_) for @modules_without_version;
        next;
      }

      # Replace with the main module if none is versioned
      my $dist = _dist_from_uri($uri);
      (my $main_module = $dist) =~ s/-/::/g;
      if ($self->_get_uri($main_module)) {
        $req->add_minimum($main_module);
        for my $module (@modules_without_version) {
          next if $main_module eq $module;
          $req->clear_requirement($module);
          if ($self->{verbose}) {
            print STDERR "  deduped $module (in favor of $main_module)\n";
          }
        }
      } else {
        # special case for distributions without a main module
        my %score;
        for my $module (@modules_without_version) {
          my $depth = $module =~ s/::/::/g;
          my $length = length $module;
          $score{$module} = join ".", ($depth || 0), $length;
        }
        my $topmost = (sort {$score{$a} <=> $score{$b} or $a cmp $b} @modules_without_version)[0];
        for my $module (@modules_without_version) {
          next if $topmost eq $module;
          $req->clear_requirement($module);
          if ($self->{verbose}) {
            print STDERR "  deduped $module (in favor of $topmost)\n";
          }
        }
      }
    }
  }
}

sub _scan_dir {
  my ($self, $dir) = @_;
  find ({
    no_chdir => 1,
    wanted => sub {
      my $file = $_;
      return unless -f $file;
      my $relpath = File::Spec->abs2rel($file, $self->{base_dir});

      return unless $relpath =~ /\.(?:pl|PL|pm|cgi|psgi|t)$/ or
                    dirname($relpath) =~ m!\b(?:bin|scripts?)$! or
                    ($self->{develop} and $relpath =~ /^(?:author)\b/);
      $self->_scan_file($file);
    },
  }, $dir);
}

sub _scan_file {
  my ($self, $file) = @_;

  $file =~ s|\\|/|g if WIN32;
  if ($self->{ignore_re}) {
    return if $file =~ /\b$self->{ignore_re}\b/;
  }

  my $optional = $self->{optional_re} && $file =~ /\b$self->{optional_re}\b/ ? 1 : 0;

  my $context = Perl::PrereqScanner::NotQuiteLite->new(
    parsers => $self->{parsers},
    recommends => $self->{recommends},
    suggests => $self->{suggests},
    verbose => $self->{verbose},
    optional => $optional,
  )->scan_file($file);

  my $relpath = File::Spec->abs2rel($file, $self->{base_dir});
  $relpath =~ s|\\|/|g if WIN32;

  my $prereqs = $self->{prereqs};
  if ($self->{features}) {
    for my $identifier (keys %{$self->{features}}) {
      my $feature = $self->{features}{$identifier};
      if (grep {$file =~ m!^$_(?:/|$)!} @{$feature->{paths}}) {
        $prereqs = $feature->{prereqs} ||= CPAN::Meta::Prereqs->new;
        last;
      }
    }
  }

  if ($relpath =~ m!(?:^|[\\/])t[\\/]!) {
    if ($relpath =~ /\.t$/) {
      $self->_add($prereqs, test => $context);
    } elsif ($relpath =~ /\.pm$/) {
      $self->{_test_pm}{$relpath} = $context;
    }
  } elsif ($relpath =~ m!(?:^|[\\/])(?:xt|inc|author)[\\/]!) {
    $self->_add($prereqs, develop => $context);
  } elsif ($relpath =~ m!(?:(?:^|[\\/])Makefile|^Build)\.PL$!) {
    $self->_add($prereqs, configure => $context);
  } elsif ($relpath =~ m!(?:^|[\\/])(?:.+)\.PL$!) {
    $self->_add($prereqs, build => $context);
  } else {
    $self->_add($prereqs, runtime => $context);
  }

  if ($relpath =~ /\.pm$/) {
    my $module = $relpath;
    $module =~ s!\.pm$!!;
    $module =~ s![\\/]!::!g;
    $self->{possible_modules}{$module} = $relpath;
    $module =~ s!^(?:inc|blib|x?t)::!!;
    $self->{possible_modules}{$module} = $relpath;
    $module =~ s!^lib::!!;
    $self->{possible_modules}{$module} = $relpath;
  }
}

sub _add {
  my ($self, $prereqs, $phase, $context) = @_;

  $prereqs->requirements_for($phase, 'requires')
          ->add_requirements($context->requires);

  if ($self->{suggests} or $self->{recommends}) {
    $prereqs->requirements_for($phase, 'recommends')
            ->add_requirements($context->recommends);
  }

  if ($self->{suggests}) {
    $prereqs->requirements_for($phase, 'suggests')
            ->add_requirements($context->suggests);
  }
}

1;

__END__