cpangrep

#!/usr/bin/env perl
use 5.012;
use strict;
use warnings;
use autodie;
use Archive::Zip qw(:ERROR_CODES :CONSTANTS);
use Archive::Zip::MemberRead;
use Archive::Tar;
use CPAN::Visitor;
use CPAN::Mini;
use Getopt::Lucid ":all";

my $perl_suffixes = qr/\.(?:pl|pm|t)\z/;

my $opts = Getopt::Lucid->getopt(
  [
    Param("jobs|j")->valid(qr/\d+/)->default(1),
    Param("match|m"),
    Param("dir|d"),
    List("select|s"),
  ]
);

die "No '--match' option\n"
  unless $opts->get_match;

unless ($opts->get_dir) {
  my %config = CPAN::Mini->read_config;
  die "Must specific 'local: <path>' in .minicpanrc\n"
    unless $config{local} && -d $config{local};
  $opts->merge_defaults( dir => $config{local} );
}

my $visitor = CPAN::Visitor->new( cpan => $opts->get_dir );

my @selectors = (
  exclude => qr{/Acme-},
);

if ( $opts->get_select ) {
  push @selectors, 'match' => [ map {; qr/$_/ } $opts->get_select ];
}

$visitor->select( @selectors );

# Action is specified via a callback
$visitor->iterate(
  jobs => $opts->get_jobs,
  enter => sub { 1 },
  leave => sub { 1 },
  extract => \&my_extract,
  visit => sub {
    my $job = shift;
    my $archive = $job->{result}{extract};
    my $gen_fh = $archive->{handle_cb};
    my $file_map = $archive->{files};
    my $pattern = $opts->get_match;
    for my $name ( sort keys %$file_map ) {
      my $fh = $gen_fh->($file_map->{$name});
      if ( ! $fh ) {
        warn "Couldn't get handle for $name\n";
        next;
      }
      my @lines;
      while (defined(my $_=$fh->getline)) {
        chomp;
        push @lines, $_ if /$pattern/;
      }
      if (@lines) {
        say "$name:";
        say "  $_" for @lines;
        say "";
      }
    }
  }
);

# keep it all in memory and save the disk IO
# return a hash:
#    files => hashref of name, object pairs
#    handle_cb => sub that given an object returns a file handle
sub my_extract {
  my $job = shift;

  if ($job->{distpath} =~ /\.zip$/i) {
    my $zip = Archive::Zip->new;
    if ( $zip->read( $job->{distpath} ) == AZ_OK ) {
      my @files = $zip->membersMatching( $perl_suffixes );
      return {
        files => { map { $_->fileName => $_ } @files },
        handle_cb => sub { Archive::Zip::MemberRead->new(shift) },
      }
    }
  }
  elsif ( my $tar = Archive::Tar->new($job->{distpath})) {
    my @files = grep { $_->type == Archive::Tar::Constant::FILE }
                $tar->get_files( grep { /$perl_suffixes/ } $tar->list_files );
    return {
      files => { map { $_->full_path => $_ } @files },
      handle_cb => sub { 
        my $file = shift;
        my $content_ref = $file->get_content_by_ref;
        unless ( $content_ref && length $$content_ref ) {
          warn "no content in " . $file->full_path ."\n";
          return;
        }
        open my $fh, "<", $content_ref;
        return $fh;
      },
    }
  }
  else {
    return {};
  }
}