File Coverage

lib/Parse/LocalDistribution.pm

Criterion	Covered	Total	%
statement	158	221	71.4
branch	43	96	44.7
condition	18	70	25.7
subroutine	22	28	78.5
pod	2	2	100.0
total	243	417	58.2

package Parse::LocalDistribution;

use strict;
use warnings;
use Parse::PMFile;
use List::Util ();
use Parse::CPAN::Meta ();
use File::Spec;
use File::Find;
use Cwd ();

our $VERSION = '0.17';

sub new {
  my ($class, $root, $opts) = @_;
  if (ref $root eq ref {} && !$opts) {
    $opts = $root; $root = undef;
  }
  $opts ||= {};
  bless $opts, $class;
}

# adapted from PAUSE::mldistwatch#check_for_new
sub parse {
  my ($self, $root) = @_;
  $self->{DISTROOT} = $self->{DIST} = $root ||= Cwd::cwd();

  $self->_read_dist;
  $self->_extract_meta;
  $self->_examine_pms;
}

# from PAUSE::dist;
sub _read_dist {
  my $self = shift;
  # TODO: support absolute path
  my(@manifind) = $self->_find_files;
  my $manifound = @manifind;
  $self->{MANIFOUND} = \@manifind;
  my $dist = $self->{DIST};
  unless (@manifind){
    $self->_verbose(1,"NO FILES! in dist $dist?");
    return;
  }
  $self->_verbose(1,"Found $manifound files in dist $dist, first $manifind[0]\n");
}

# from PAUSE::dist;
sub _extract_meta {
  my $self = shift;

  my $dist = $self->{DIST};
  my @manifind = @{$self->{MANIFOUND}};

  my $json = List::Util::reduce { length $a < length $b ? $a : $b }
             grep !m|/t/|, grep m|/META\.json$|, @manifind;
  my $yaml = List::Util::reduce { length $a < length $b ? $a : $b }
             grep !m|/t/|, grep m|/META\.yml$|, @manifind;

  # META.json located only in a subdirectory should not precede
  # META.yml located in the top directory. (eg. Test::Module::Used 0.2.4)
  if ($json && $yaml && length($json) > length($yaml) + 1) {
    $json = '';
  }

  unless ($json || $yaml) {
    $self->{METAFILE} = "No META.yml or META.json found";
    $self->_verbose(1,"No META.yml or META.json in $dist");
    return;
  }

  for my $metafile ($json || $yaml) {
    my $metafile_abs = File::Spec->catfile($self->{DISTROOT}, $metafile);
    $metafile_abs =~ s|\\|/|g;
    if (-s $metafile_abs) {
      $self->{METAFILE} = $metafile;
      my $ok = eval {
        $self->{META_CONTENT} = Parse::CPAN::Meta->load_file($metafile_abs); 1
      };
      unless ($ok) {
        $self->_verbose(1,"Error while parsing $metafile: $@");
        $self->{META_CONTENT} = {};
        $self->{METAFILE} = "$metafile found but error "
                          . "encountered while loading: $@";
      }
    } else {
      $self->{METAFILE} = "Empty $metafile found, ignoring\n";
    }
  }
}

# from PAUSE::dist;
sub _examine_pms {
  my $self = shift;

  my $dist = $self->{DIST};

  my $pmfiles = $self->_filter_pms;
  my($meta, $provides, $indexing_method);
  if (my $version_from_meta_ok = $self->_version_from_meta_ok) {
    $meta = $self->{META_CONTENT};
    $provides = $meta->{provides};
    if ($provides && "HASH" eq ref $provides) {
      $indexing_method = '_index_by_meta';
    }
  }
  if (! $indexing_method && @$pmfiles) { # examine files
    $indexing_method = '_index_by_files';
  }

  if ($indexing_method) {
    return $self->$indexing_method($pmfiles, $provides);
  }
  return {};
}

# from PAUSE::dist
sub _index_by_files {
  my ($self, $pmfiles, $provides) = @_;
  my $dist = $self->{DIST};

  my %result;
  my $parser = Parse::PMFile->new($self->{META_CONTENT}, $self);
  for my $pmfile (@$pmfiles) {
    my $pmfile_abs = File::Spec->catfile($self->{DISTROOT}, $pmfile);
    $pmfile_abs =~ s|\\|/|g;
    if ($pmfile_abs =~ m|/blib/|) {
      $self->_verbose(1,"Still a blib directory detected:
        dist[$dist]pmfile[$pmfile]
        ");
      next;
    }

    my ($info, $errs) = $parser->parse($pmfile_abs);

    for my $package (keys %$info) {
      if (!defined $result{$package} or $info->{$package}{simile}) {
        $result{$package} = $info->{$package};
      }
    }
    if ($errs) {
      for my $package (keys %$errs) {
        for (keys %{$errs->{$package}}) {
          $result{$package}{$_ =~ /infile|warning/ ? $_ : $_.'_error'} = $errs->{$package}{$_};
        }
      }
    }
  }
  return \%result;
}

# from PAUSE::dist
sub _index_by_meta {
  my ($self, $pmfiles, $provides) = @_;
  my $dist = $self->{DIST};

  my %result;
  while (my($k,$v) = each %$provides) {
    next if ref $v ne ref {};
    next if !defined $v->{file} or $v->{file} eq '';
    $v->{infile} = "$v->{file}";
    my @stat = stat File::Spec->catfile($self->{DISTROOT}, $v->{file});
    if (@stat) {
      $v->{filemtime} = $stat[9];
    } else {
      $v->{filemtime} = 0;
    }
    unless (defined $v->{version}) {
      # 2009-09-23 get a bugreport due to
      # RKITOVER/MooseX-Types-0.20.tar.gz not
      # setting version for MooseX::Types::Util
      $v->{version} = "undef";
    }
    # going from a distro object to a package object
    # is only possible via a file object

    $self->_examine_pkg({package => $k, pp => $v}) or next;

    $result{$k} = $v;
  }
  return \%result;
}

# from PAUSE::package;
sub _examine_pkg {
  my ($self, $args) = @_;
  my $package = $args->{package};
  my $pp = $args->{pp};

  # should they be cought earlier? Maybe.
  # but as an ultimate sanity check suggested by Richard Soderberg
  # XXX should be in a separate sub and be tested
  if ($package !~ /^\w[\w\:\']*\w?\z/
      ||
      $package !~ /\w\z/
      ||
      $package =~ /:/ && $package !~ /::/
      ||
      $package =~ /\w:\w/
      ||
      $package =~ /:::/
      ){
      $self->_verbose(1,"Package[$package] did not pass the ultimate sanity check");
      return;
  }

  if ($self->{USERID} && $self->{PERMISSIONS} && !$self->_perm_check($package)) {
      return;
  }

  # No parser problem should be found
  # (only used for META provides in this module)

  # Sanity checks

  for (
        $package,
        $pp->{version},
      ) {
      if (!defined || /^\s*$/ || /\s/){  # for whatever reason I come here
          return;            # don't screw up 02packages
      }
  }
  return unless $self->_version_ok($pp);

  $pp;
}

sub _version_ok {
  my ($self, $pp) = @_;
  return if length($pp->{version} || 0) > 16;
  return 1
}

# from PAUSE::dist;
sub _filter_pms {
  my($self) = @_;
  my @pmfile;

  # very similar code is in PAUSE::package::filter_ppps
  MANI: for my $mf ( @{$self->{MANIFOUND}} ) {
    next unless $mf =~ /\.pm(?:\.PL)?$/i;
    my($inmf) = $mf =~ m!^[^/]+/(.+)!; # go one directory down

    # skip "t" - libraries in ./t are test libraries!
    # skip "xt" - libraries in ./xt are author test libraries!
    # skip "inc" - libraries in ./inc are usually install libraries
    # skip "local" - somebody shipped his carton setup!
    # skip 'perl5" - somebody shipped her local::lib!
    # skip 'fatlib" - somebody shipped their  fatpack lib!
    next if $inmf =~ m!^(?:x?t|inc|local|perl5|fatlib)/!;

    if ($self->{META_CONTENT}){
      my $no_index = $self->{META_CONTENT}{no_index}
      || $self->{META_CONTENT}{private}; # backward compat
      if (ref($no_index) eq 'HASH') {
        my %map = (
          file => qr{\z},
          directory => qr{/},
        );
        for my $k (qw(file directory)) {
          next unless my $v = $no_index->{$k};
          my $rest = $map{$k};
          if (ref $v eq "ARRAY") {
            for my $ve (@$v) {
              $ve =~ s|\\|/|g; # Class-InsideOut-0.90_01
              $ve =~ s|/+$||;
              if ($inmf =~ /^$ve$rest/){
                $self->_verbose(1,"Skipping inmf[$inmf] due to ve[$ve]");
                next MANI;
              } else {
                $self->_verbose(1,"NOT skipping inmf[$inmf] due to ve[$ve]");
              }
            }
          } else {
            $v =~ s|/+$||;
            if ($inmf =~ /^$v$rest/){
              $self->_verbose(1,"Skipping inmf[$inmf] due to v[$v]");
              next MANI;
            } else {
              $self->_verbose(1,"NOT skipping inmf[$inmf] due to v[$v]");
            }
          }
        }
      } else {
        # noisy:
        # $self->_verbose(1,"no keyword 'no_index' or 'private' in META_CONTENT");
      }
    } else {
      # $self->_verbose(1,"no META_CONTENT"); # too noisy
    }
    push @pmfile, $mf;
  }
  $self->_verbose(1,"Finished with pmfile[@pmfile]\n");
  \@pmfile;
}

sub _version_from_meta_ok { Parse::PMFile::_version_from_meta_ok(@_) }
sub _verbose { Parse::PMFile::_verbose(@_) }
sub _perm_check { Parse::PMFile::_perm_check(@_) }

# instead of ExtUtils::Manifest::manifind()
# which only looks for files under the current directory.
# We also need to look at MANIFEST/MANIFEST.SKIP here because
# unwanted files are not excluded yet.
# If we have MANIFEST, assume it's up-to-date and lists everything
# we need. If we have only MANIFEST.SKIP, then look for files
# and discard the matched.
sub _find_files {
  my $self = shift;

  my @files = $self->_find_files_from_manifest;
  return sort @files if @files;

  my $skip = $self->_prepare_skip;

  my $root = $self->{DISTROOT};
  my $wanted = sub {
    my $name = $File::Find::name;
    return if -d $_;
    return if $name =~ m!/(?:\.(?:svn|git)|blib)/!; # too common
    my $rel = File::Spec->abs2rel($name, $root);
    $rel =~ s|\\|/|g;
    return if $skip && $skip->($rel);
    push @files, "./$rel";
  };

  File::Find::find(
    {wanted => $wanted, follow => 0, no_chdir => 1}, $root
  );

  return sort @files;
}

# adapted from ExtUtils::Manifest::maniread
sub _find_files_from_manifest {
  my $self = shift;
  my $root = $self->{DISTROOT};
  my $manifile = "$root/MANIFEST";
  return unless -f $manifile;

  my %files;
  open my $fh, '<', $manifile or return;
  while(<$fh>) {
    next if /^\s*#/;
    chomp;
    my ($file, $comment);
    if (($file, $comment) = /^'(\\[\\']|.+)+'\s*(.*)/) {
      $file =~ s/\\([\\'])/$1/g;
    }
    else {
      ($file, $comment) = /^(\S+)\s*(.*)/;
    }
    next unless $file;
    $files{"./$file"} = $comment;
  }
  sort keys %files;
}

# adapted from ExtUtils::Manifest::maniskip
sub _prepare_skip {
  my $self = shift;
  my $root = $self->{DISTROOT};
  my $skipfile = "$root/MANIFEST.SKIP";
  return unless -f $skipfile;

  my @skip;
  open my $fh, '<', $skipfile or return;
  while(<$fh>) {
    chomp;
    s/\r//;
    m{^\s*(?:(?:'([^\\']*(?:\\.[^\\']*)*)')|([^#\s]\S*))?(?:(?:\s*)|(?:\s+(.*?)\s*))$};
    my $filename = $2;
    if ( defined($1) ) {
      $filename = $1;
      $filename =~ s/\\(['\\])/$1/g;
    }
    next if not defined($filename) or not $filename;
    push @skip, $filename;
  }
  return unless @skip;
  my $re = join '|', map "(?:$_)", @skip;

  return sub {$_[0] =~ /$re/};
}

1;

__END__