public
Created

acme's search_cpan.pl with threads

  • Download Gist
search_cpan.pl
Perl
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74
#!/usr/bin/perl
use strict;
use threads;
use threads::shared;
use warnings;
use 5.12.0;
use Archive::Peek::Libarchive;
use Parse::CPAN::Packages;
use Path::Class;
use Term::ANSIColor;
 
my $CPAN = shift || die "Must pass path to local CPAN mirror";
my $search = shift || die "Must pass regular expression to use";
 
my $packages
= Parse::CPAN::Packages->new("$CPAN/modules/02packages.details.txt.gz");
 
my $lines :shared;
 
my @distributions :shared
= map { $_->prefix }
sort { $a->distvname cmp $b->distvname }
grep {
!( $_->prefix =~ m{/(?:emb|syb|bio)?perl-\d}i
|| $_->prefix =~ m{/(?:parrot|ponie)-\d}i
|| $_->prefix =~ m{/(?:kurila)-\d}i
|| $_->prefix =~ m{/\bperl-?5\.004}i
|| $_->prefix =~ m{/\bperl_mlb\.zip}i )
} $packages->latest_distributions;
 
map $_->join, map threads->create(\&process), 1 .. 5;
 
sub process {
while(my $distribution_prefix = shift @distributions) {
my $archive = file( $CPAN, 'authors', 'id', $distribution_prefix );
 
eval {
my $peek = Archive::Peek::Libarchive->new( filename => $archive );
$peek->iterate(
sub {
my ( $filename, $contents ) = @_;
return unless $filename =~ /\.(pl|pm)$/;
my $key = $archive . ':' . $filename;
while ( $contents =~ /$search/g ) {
my $pos = pos($contents);
 
my $previous = rindex( $contents, "\n", $-[0] );
$previous = 1 + rindex( $contents, "\n", $previous - 1 )
if $previous > 0;
my $next = index( $contents, "\n", $+[0] );
$next = index( $contents, "\n", 1 + $next ) if $next > 0;
 
# Limit length of snippet, 200 bytes should be enough for anyone
if ( $next > $previous + 200 ) {
$previous
= $previous < $-[0] - 100
? $-[0] - 100
: $previous;
$next = $next > $+[0] + 100 ? $+[0] + 100 : $next;
}
 
my $snippet
= substr( $contents, $previous, $next - $previous );
$snippet
=~ s{$search}{color('black on_yellow') . $& . color('reset')}eg;
say '' if $lines++;
say color('bold green'), $key, color('reset');
say "$snippet";
}
}
);
};
}
}

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.