package Module::Provision::TraitFor::PrereqDifferences;
use namespace::autoclean;
use Class::Usul::Constants;
use Class::Usul::Functions qw( classfile ensure_class_loaded
is_member emit io );
use Config::Tiny;
use English qw( -no_match_vars );
use Module::Metadata;
use Perl::Version;
use Moo::Role;
with q(Class::Usul::TraitFor::MetaData);
requires qw( appldir builder chdir debug get_package_meta libdir
manifest_paths next_argv output project_file run_cmd );
# Public methods
sub prereq_diffs : method {
my $self = shift;
ensure_class_loaded( 'CPAN' );
ensure_class_loaded( 'Module::CoreList' );
ensure_class_loaded( 'Pod::Eventual::Simple' );
my $field = $self->next_argv || 'requires';
my $filter = "_filter_${field}_paths";
my $sources = $self->$filter( $self->_source_paths );
my $depends = $self->_filter_dependents( $self->_dependencies( $sources ) );
__emit_diffs( $self->_compare_prereqs_with_used( $field, $depends ) );
return OK;
}
# Private methods
sub _compare_prereqs_with_used {
my ($self, $field, $depends) = @_;
my $file = $self->project_file;
my $prereqs = $self->_prereq_data->{ $field };
my $add_key = "Would add these to the ${field} in ${file}";
my $remove_key = "Would remove these from the ${field} in ${file}";
my $update_key = "Would update these in the ${field} in ${file}";
my $result = {};
for (grep { defined $depends->{ $_ } } keys %{ $depends }) {
if (exists $prereqs->{ $_ }) {
if (__version_diff( $prereqs->{ $_ }, $depends->{ $_ } )) {
$result->{ $update_key }->{ $_ }
= $prereqs->{ $_ }.q( => ).$depends->{ $_ };
}
}
else { $result->{ $add_key }->{ $_ } = $depends->{ $_ } }
}
for (keys %{ $prereqs }) {
exists $depends->{ $_ }
or $result->{ $remove_key }->{ $_ } = $prereqs->{ $_ };
}
return $result;
}
sub _consolidate {
my ($self, $used) = @_; my (%dists, %result);
for my $used_key (keys %{ $used }) {
my ($curr_dist, $module, $used_dist); my $try_module = $used_key;
while ($curr_dist = __dist_from_module( $try_module ) and (not $used_dist
or $curr_dist->base_id eq $used_dist->base_id)) {
$module = $try_module;
$used_dist or $used_dist = $curr_dist;
$try_module =~ m{ :: }mx or last;
$try_module =~ s{ :: [^:]+ \z }{}mx;
}
if ($used_dist
and (not $curr_dist or $used_dist->base_id ne $curr_dist->base_id)) {
my $was = $module;
$module = __recover_module_name( $used_dist->base_id );
$self->debug and $self->output( "Recovered ${module} from ${was}" );
}
if ($module) {
not exists $dists{ $module }
and $dists{ $module } = $self->_version_from_module( $module );
}
else { $result{ $used_key } = $used->{ $used_key } }
}
$result{ $_ } = $dists{ $_ } for (keys %dists);
return \%result;
}
sub _dependencies {
my ($self, $paths) = @_; my $used = {};
for my $path (@{ $paths }) {
my $lines = __read_non_pod_lines( $path );
for my $line (split m{ \n }mx, $lines) {
my $modules = __parse_depends_line( $line ); $modules->[ 0 ] or next;
for (@{ $modules }) {
__looks_like_version( $_ ) and $used->{perl} = $_ and next;
not exists $used->{ $_ }
and $used->{ $_ } = $self->_version_from_module( $_ );
}
}
}
return $used;
}
sub _filter_dependents {
my ($self, $used) = @_;
my $perl_version = $used->{perl} || 5.008_008;
my $core_modules = $Module::CoreList::version{ $perl_version };
my $dir = $self->builder eq 'DZ'
? $self->distname.'-'.$self->dist_version : undef;
my $provides = $self->get_package_meta( $dir )->provides;
return $self->_consolidate( { map { $_ => $used->{ $_ } }
grep { not exists $core_modules->{ $_ } }
grep { not exists $provides->{ $_ } }
keys %{ $used } } );
}
sub _filter_build_requires_paths {
return [ grep { m{ (?: \.pm | \.t ) \z }mx }
grep { m{ \A t \b }mx } @{ $_[ 1 ] } ];
}
sub _filter_configure_requires_paths {
my $file = $_[ 0 ]->project_file;
return [ grep { m{ \A inc }mx || $_ eq $file } @{ $_[ 1 ] } ];
}
sub _filter_requires_paths {
my $file = $_[ 0 ]->project_file;
my $pattern = $file eq 'dist.ini' ? '(?: Build.PL | Makefile.PL )' : $file;
return [ grep { not m{ \A (?: inc | t ) \b }mx
and not m{ \A $pattern \z }mx } @{ $_[ 1 ] } ];
}
sub _is_perl_source {
my ($self, $path) = @_;
$path =~ m{ (?: \.pm | \.t | \.pl ) \z }imx and return TRUE;
my $line = io( $path )->getline; $line or return FALSE;
return $line =~ m{ \A \#! (?: .* ) perl (?: \s | \z ) }mx ? TRUE : FALSE;
}
sub _prereq_data {
my $self = shift; $self->chdir( $self->appldir );
if ($self->builder eq 'DZ') {
my $cfg = Config::Tiny->read( 'dist.ini' );
return { build_requires => $cfg->{ 'Prereqs / BuildRequires' },
configure_requires => $cfg->{ 'Prereqs / ConfigureRequires' },
recommends => $cfg->{ 'Prereqs / Recommends' },
requires => $cfg->{ 'Prereqs' }, };
}
elsif ($self->builder eq 'MB') {
my $cmd = "${EXECUTABLE_NAME} Build.PL; ./Build prereq_data";
return eval $self->run_cmd( $cmd )->stdout;
}
return {};
}
sub _source_paths {
return [ grep { $_[ 0 ]->_is_perl_source( $_ ) }
@{ $_[ 0 ]->manifest_paths } ];
}
sub _version_from_module {
my ($self, $module) = @_;
my $inc = [ $self->libdir, @INC ];
my $info = Module::Metadata->new_from_module( $module, inc => $inc );
my $ver; $info and $info->version and $ver = $info->version;
return $ver ? Perl::Version->new( $ver ) : undef;
}
# Private functions
sub __dist_from_module {
my $module = CPAN::Shell->expand( 'Module', $_[ 0 ] );
return $module ? $module->distribution : undef;
}
sub __draw_line {
return emit q(-) x ($_[ 0 ] || 60);
}
sub __emit_diffs {
my $diffs = shift; __draw_line();
for my $table (sort keys %{ $diffs }) {
emit $table; __draw_line();
for (sort keys %{ $diffs->{ $table } }) {
emit "'$_' => ".$diffs->{ $table }->{ $_ }.",";
}
__draw_line();
}
return;
}
sub __extract_statements_from {
my $line = shift;
return grep { length }
map { s{ \A \s+ }{}mx; s{ \s+ \z }{}mx; $_ } split m{ ; }mx, $line;
}
sub __looks_like_version {
my $ver = shift;
return defined $ver && $ver =~ m{ \A v? \d+ (?: \.[\d_]+ )? \z }mx;
}
sub __parse_depends_line {
my $line = shift; my $modules = [];
for my $stmt (__extract_statements_from( $line )) {
if ($stmt =~ m{ \A (?: use | require ) \s+ }mx) {
my (undef, $module, $rest) = split m{ \s+ }mx, $stmt, 3;
# Skip common pragma and things that don't look like module names
$module =~ m{ \A (?: lib | strict | warnings ) \z }mx and next;
$module =~ m{ [^\.:\w] }mx and next;
push @{ $modules }, $module eq q(base) || $module eq q(parent)
? ($module, __parse_list( $rest )) : $module;
}
elsif ($stmt =~ m{ \A (?: with | extends ) \s+ (.+) }mx) {
push @{ $modules }, __parse_list( $1 );
}
elsif ($stmt =~ m{ ensure_class_loaded \( \s* (.+?) \s* \) }mx) {
my $module = $1;
$module = $module =~ m{ \A [q\'\"] }mx ? eval $module : $module;
push @{ $modules }, $module;
}
}
return $modules;
}
sub __parse_list {
my $string = shift;
$string =~ s{ \A q w* [\(/] \s* }{}mx;
$string =~ s{ \s* [\)/] \z }{}mx;
$string =~ s{ [\'\"] }{}gmx;
$string =~ s{ , }{ }gmx;
return grep { length && !m{ [^\.:\w] }mx } split m{ \s+ }mx, $string;
}
sub __read_non_pod_lines {
my $path = shift; my $p = Pod::Eventual::Simple->read_file( $path );
return join "\n", map { $_->{content} }
grep { $_->{type} eq q(nonpod) } @{ $p };
}
sub __recover_module_name {
my $id = shift; my @parts = split m{ [\-] }mx, $id; my $ver = pop @parts;
return join '::', @parts;
}
sub __version_diff {
my ($prereq, $depend) = @_;
$prereq =~ s{ (\. [0-9]+?) 0+ \z }{$1}mx;
$depend =~ s{ (\. [0-9]+?) 0+ \z }{$1}mx;
my $oldver = Perl::Version->new( $prereq ); $oldver->components( 2 );
my $newver = Perl::Version->new( $depend ); $newver->components( 2 );
return $oldver != $newver ? TRUE : FALSE;
}
1;
__END__
=pod
=encoding utf8
=head1 Name
Module::Provision::TraitFor::PrereqDifferences - Displays a prerequisite difference report
=head1 Synopsis
use Moose;
extends 'Module::Provision::Base';
with 'Module::Provision::TraitFor::PrereqDifferences';
=head1 Description
Displays a prerequisite difference report
=head1 Configuration and Environment
Defines no attributes
=head1 Subroutines/Methods
=head2 prereq_diffs - Displays a prerequisite difference report
$exit_code = $self->prereq_diffs;
Shows which dependencies should be added to, removed from, or updated
in the the distributions project file
=head1 Diagnostics
None
=head1 Dependencies
=over 3
=item L<Class::Usul>
=item L<CPAN>
=item L<Module::CoreList>
=item L<Moose::Role>
=item L<Pod::Eventual::Simple>
=back
=head1 Incompatibilities
There are no known incompatibilities in this module
=head1 Bugs and Limitations
There are no known bugs in this module.
Please report problems to the address below.
Patches are welcome
=head1 Acknowledgements
Larry Wall - For the Perl programming language
=head1 Author
Peter Flanigan, C<< <pjfl@cpan.org> >>
=head1 License and Copyright
Copyright (c) 2013 Peter Flanigan. All rights reserved
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself. See L<perlartistic>
This program is distributed in the hope that it will be useful,
but WITHOUT WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE
=cut
# Local Variables:
# mode: perl
# tab-width: 3
# End: