# ABSTRACT: Extract packages provided/required by a distribution archive
package Pinto::PackageExtractor;
use Moose;
use MooseX::StrictConstructor;
use MooseX::Types::Moose qw(HashRef Bool);
use MooseX::MarkAsMethods ( autoclean => 1 );
use Try::Tiny;
use Dist::Metadata;
use Path::Class qw(dir);
use Archive::Extract;
use Pinto::Types qw(File Dir);
use Pinto::Util qw(debug throw whine);
use Pinto::ArchiveUnpacker;
#-----------------------------------------------------------------------------
our $VERSION = '0.091'; # VERSION
#-----------------------------------------------------------------------------
has archive => (
is => 'ro',
isa => File,
required => 1,
coerce => 1,
);
has unpacker => (
is => 'ro',
isa => 'Pinto::ArchiveUnpacker',
default => sub { Pinto::ArchiveUnpacker->new( archive => $_[0]->archive ) },
init_arg => undef,
lazy => 1,
);
has work_dir => (
is => 'ro',
isa => Dir,
default => sub { $_[0]->unpacker->unpack },
init_arg => undef,
lazy => 1,
);
has dm => (
is => 'ro',
isa => 'Dist::Metadata',
default => sub { Dist::Metadata->new( dir => $_[0]->work_dir, include_inner_packages => 1 ) },
init_arg => undef,
lazy => 1,
);
#-----------------------------------------------------------------------------
sub provides {
my ($self) = @_;
my $archive = $self->archive;
debug "Extracting packages provided by archive $archive";
my $mod_info = try {
# Some modules get their VERSION by loading some other
# module from lib/. So make sure that lib/ is in @INC
my $lib_dir = $self->work_dir->subdir('lib');
local @INC = ( $lib_dir->stringify, @INC );
# TODO: Run this under Safe to protect ourselves
# from evil. See ANDK/pause/pmfile.pm for example
$self->dm->module_info; # returned from try{}
}
catch {
throw "Unable to extract packages from $archive: $_";
};
my @provides;
for my $pkg_name ( sort keys %{$mod_info} ) {
my $info = $mod_info->{$pkg_name};
my $pkg_ver = version->parse( $info->{version} );
debug "Archive $archive provides: $pkg_name-$pkg_ver";
push @provides, { name => $pkg_name, version => $pkg_ver };
}
@provides = $self->__apply_workarounds if @provides == 0;
whine sprintf "%s contains no packages and will not be indexed",
$archive->basename if not @provides;
return @provides;
}
#-----------------------------------------------------------------------------
sub requires {
my ($self) = @_;
my $archive = $self->archive;
debug "Extracting packages required by archive $archive";
my $prereqs_meta = try { $self->dm->meta->prereqs } catch { throw "Unable to extract prereqs from $archive: $_" };
my @prereqs;
for my $phase ( keys %{$prereqs_meta} ) {
my $prereqs_for_phase = $prereqs_meta->{$phase} || {};
my $required_prereqs = $prereqs_for_phase->{requires} || {};
for my $pkg_name ( sort keys %{$required_prereqs} ) {
my $pkg_ver = version->parse( $required_prereqs->{$pkg_name} );
debug "Archive $archive requires ($phase): $pkg_name-$pkg_ver";
my $struct = { phase => $phase, name => $pkg_name, version => $pkg_ver };
push @prereqs, $struct;
}
}
return @prereqs;
}
#-----------------------------------------------------------------------------
sub metadata {
my ($self) = @_;
my $archive = $self->archive;
debug "Extracting metadata from archive $archive";
my $metadata = try { $self->dm->meta } catch { throw "Unable to extract metadata from $archive: $_" };
return $metadata;
}
#-----------------------------------------------------------------------------
# HACK: The common-sense and FCGI distributions generate the .pm file at build
# time. It relies on an unusual feature of PAUSE that scans the __DATA__
# section of .PM files for potential packages. Module::Metdata doesn't have
# that feature, so to us, it appears that these distributions contain no packages.
# I've asked the authors to use the "provides" field of the META file so
# that other tools can discover the packages in the distribution, but then have
# not done so. So we work around it by just assuming the distribution contains a
# package named "common::sense" or "FCGI".
sub __apply_workarounds {
my ($self) = @_;
return $self->__common_sense_workaround
if $self->archive->basename =~ m/^ common-sense /x;
return $self->__fcgi_workaround
if $self->archive->basename =~ m/^ FCGI-\d /x;
return;
}
#-----------------------------------------------------------------------------
# TODO: Generalize both of these workaround methods into a single method that
# just guesses the package name and version based on the distribution name.
sub __common_sense_workaround {
my ($self) = @_;
my ($version) = ( $self->archive->basename =~ m/common-sense- ([\d_.]+) \.tar\.gz/x );
return {
name => 'common::sense',
version => version->parse($version)
};
}
#-----------------------------------------------------------------------------
# TODO: Generalize both of these workaround methods into a single method that
# just guesses the package name and version based on the distribution name.
sub __fcgi_workaround {
my ($self) = @_;
my ($version) = ( $self->archive->basename =~ m/FCGI- ([\d_.]+) \.tar\.gz/x );
return {
name => 'FCGI',
version => version->parse($version)
};
}
#-----------------------------------------------------------------------------
__PACKAGE__->meta->make_immutable;
#-----------------------------------------------------------------------------
1;
__END__
=pod
=encoding utf-8
=for :stopwords Jeffrey Ryan Thalhammer BenRifkah Fowler Jakob Voss Karen Etheridge Michael
G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton
Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson
David Steinbrunner Glenn
=head1 NAME
Pinto::PackageExtractor - Extract packages provided/required by a distribution archive
=head1 VERSION
version 0.091
=head1 AUTHOR
Jeffrey Ryan Thalhammer <jeff@stratopan.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2013 by Jeffrey Ryan Thalhammer.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut