File Coverage

lib/Module/Provision/TraitFor/PrereqDifferences.pm
Criterion Covered Total %
statement 24 47 51.0
branch 0 4 0.0
condition 0 5 0.0
subroutine 8 12 66.6
pod 1 1 100.0
total 33 69 47.8


line stmt bran cond sub pod time code
1             package Module::Provision::TraitFor::PrereqDifferences;
2              
3 1     1   565 use namespace::autoclean;
  1         2  
  1         6  
4              
5 1     1   117 use Class::Usul::Constants qw( FALSE NUL OK TRUE );
  1         2  
  1         9  
6 1         7 use Class::Usul::Functions qw( classfile ensure_class_loaded
7 1     1   814 is_member emit io );
  1         2  
8 1     1   1752 use Config::Tiny;
  1         834  
  1         32  
9 1     1   7 use English qw( -no_match_vars );
  1         2  
  1         9  
10 1     1   353 use Module::Metadata;
  1         2  
  1         21  
11 1     1   5 use Perl::Version;
  1         2  
  1         19  
12 1     1   5 use Moo::Role;
  1         3  
  1         11  
13              
14             requires qw( appldir builder chdir debug libdir load_meta
15             manifest_paths next_argv output project_file run_cmd );
16              
17             # Private functions
18             my $_dist_from_module = sub {
19             my $module = CPAN::Shell->expand( 'Module', $_[ 0 ] );
20              
21             return $module ? $module->distribution : undef;
22             };
23              
24             my $_draw_line = sub {
25             return emit '-' x ($_[ 0 ] // 60);
26             };
27              
28             my $_extract_statements_from = sub {
29             my $line = shift;
30              
31             return grep { length }
32             map { s{ \A \s+ }{}mx; s{ \s+ \z }{}mx; $_ } split m{ ; }mx, $line;
33             };
34              
35             my $_looks_like_version = sub {
36             my $ver = shift;
37              
38             return defined $ver && $ver =~ m{ \A v? \d+ (?: \.[\d_]+ )? \z }mx;
39             };
40              
41             my $_parse_list = sub {
42             my $string = shift;
43              
44             $string =~ s{ \A q w* [\(/] \s* }{}mx;
45             $string =~ s{ \s* [\)/] \z }{}mx;
46             $string =~ s{ [\'\"] }{}gmx;
47             $string =~ s{ , }{ }gmx;
48              
49             return grep { length && !m{ [^\.:\w] }mx } split m{ \s+ }mx, $string;
50             };
51              
52             my $_read_non_pod_lines = sub {
53             my $path = shift; my $p = Pod::Eventual::Simple->read_file( $path );
54              
55             return join "\n", map { $_->{content} }
56             grep { $_->{type} eq 'nonpod' } @{ $p };
57             };
58              
59             my $_recover_module_name = sub {
60             my $id = shift; my @parts = split m{ [\-] }mx, $id; my $ver = pop @parts;
61              
62             return join '::', @parts;
63             };
64              
65             my $_version_diff = sub {
66             my ($prereq, $depend) = @_;
67              
68             $prereq =~ s{ (\. [0-9]+?) 0+ \z }{$1}mx;
69             $depend =~ s{ (\. [0-9]+?) 0+ \z }{$1}mx;
70              
71             my $oldver = Perl::Version->new( $prereq ); $oldver->components( 2 );
72             my $newver = Perl::Version->new( $depend ); $newver->components( 2 );
73              
74             return $oldver != $newver ? TRUE : FALSE;
75             };
76              
77             my $_emit_diffs = sub {
78             my $diffs = shift; $_draw_line->();
79              
80             for my $table (sort keys %{ $diffs }) {
81             emit $table; $_draw_line->();
82              
83             for (sort keys %{ $diffs->{ $table } }) {
84             emit "${_} = ".$diffs->{ $table }->{ $_ };
85             }
86              
87             $_draw_line->();
88             }
89              
90             return;
91             };
92              
93             my $_parse_depends_line = sub {
94             my $line = shift; my $modules = [];
95              
96             for my $stmt ($_extract_statements_from->( $line )) {
97             if ($stmt =~ m{ \A (?: use | require ) \s+ }mx) {
98             my (undef, $module, $rest) = split m{ \s+ }mx, $stmt, 3;
99              
100             # Skip common pragma and things that don't look like module names
101             $module =~ m{ \A (?: lib | strict | warnings ) \z }mx and next;
102             $module =~ m{ [^\.:\w] }mx and next;
103              
104             push @{ $modules }, $module eq 'base' || $module eq 'parent'
105             ? ($module, $_parse_list->( $rest )) : $module;
106             }
107             elsif ($stmt =~ m{ \A (?: with | extends ) \s+ (.+) }mx) {
108             push @{ $modules }, $_parse_list->( $1 );
109             }
110             elsif ($stmt =~ m{ ensure_class_loaded [\(]? \s* (.+?) \s* [\)]? }mx) {
111             my $module = $1;
112             $module = $module =~ m{ \A [q\'\"] }mx ? eval $module : $module;
113              
114             push @{ $modules }, $module;
115             }
116             }
117              
118             return $modules;
119             };
120              
121             # Private methods
122             my $_is_perl_source = sub {
123             my ($self, $path) = @_;
124              
125             $path =~ m{ (?: \.pm | \.t | \.pl ) \z }imx and return TRUE;
126              
127             my $line = io( $path )->getline; $line or return FALSE;
128              
129             return $line =~ m{ \A \#! (?: .* ) perl (?: \s | \z ) }mx ? TRUE : FALSE;
130             };
131              
132             my $_prereq_data = sub {
133             my $self = shift; $self->chdir( $self->appldir );
134              
135             if ($self->builder eq 'DZ') {
136             my $cfg = Config::Tiny->read( 'dist.ini' );
137              
138             return { build_requires => $cfg->{ 'Prereqs / BuildRequires' },
139             configure_requires => $cfg->{ 'Prereqs / ConfigureRequires' },
140             recommends => $cfg->{ 'Prereqs / Recommends' },
141             requires => $cfg->{ 'Prereqs' }, };
142              
143             }
144             elsif ($self->builder eq 'MB') {
145             my $cmd = "${EXECUTABLE_NAME} Build.PL; ./Build prereq_data";
146              
147             return eval $self->run_cmd( $cmd )->stdout;
148             }
149              
150             return {};
151             };
152              
153             my $_source_paths = sub {
154             return [ grep { $_[ 0 ]->$_is_perl_source( $_ ) }
155             @{ $_[ 0 ]->manifest_paths } ];
156             };
157              
158             my $_version_from_module = sub {
159             my ($self, $module) = @_;
160              
161             my $inc = [ $self->libdir, @INC ];
162             my $info = Module::Metadata->new_from_module( $module, inc => $inc );
163             my $ver; $info and $info->version and $ver = $info->version;
164              
165             return $ver ? Perl::Version->new( $ver ) : undef;
166             };
167              
168             my $_compare_prereqs_with_used = sub {
169             my ($self, $field, $depends) = @_;
170              
171             my $file = $self->project_file;
172             my $prereqs = $self->$_prereq_data->{ $field };
173             my $add_key = "Would add these to the ${field} in ${file}";
174             my $remove_key = "Would remove these from the ${field} in ${file}";
175             my $update_key = "Would update these in the ${field} in ${file}";
176             my $result = {};
177              
178             for (grep { defined $depends->{ $_ } } keys %{ $depends }) {
179             if (exists $prereqs->{ $_ }) {
180             if ($_version_diff->( $prereqs->{ $_ }, $depends->{ $_ } )) {
181             $result->{ $update_key }->{ $_ }
182             = $prereqs->{ $_ }.' => '.$depends->{ $_ };
183             }
184             }
185             else { $result->{ $add_key }->{ $_ } = $depends->{ $_ } }
186             }
187              
188             for (grep { not exists $depends->{ $_ } } keys %{ $prereqs }) {
189             my $ver = $self->$_version_from_module( $_ );
190             my $vdiff = $_version_diff->( $prereqs->{ $_ }, $ver );
191              
192             $result->{ $remove_key }->{ $_ }
193             = $prereqs->{ $_ }.($vdiff ? " => ${ver}" : NUL);
194             }
195              
196             return $result;
197             };
198              
199             my $_consolidate = sub {
200             my ($self, $used) = @_; my (%dists, %result);
201              
202             for my $used_key (keys %{ $used }) {
203             my ($curr_dist, $module, $used_dist); my $try_module = $used_key;
204              
205             while ($curr_dist = $_dist_from_module->( $try_module ) and
206             (not $used_dist or $curr_dist->base_id eq $used_dist->base_id)) {
207             $module = $try_module;
208             $used_dist or $used_dist = $curr_dist;
209             $try_module =~ m{ :: }mx or last;
210             $try_module =~ s{ :: [^:]+ \z }{}mx;
211             }
212              
213             if ($used_dist
214             and (not $curr_dist or $used_dist->base_id ne $curr_dist->base_id)) {
215             my $was = $module;
216              
217             $module = $_recover_module_name->( $used_dist->base_id );
218             $self->debug and $self->output( "Recovered ${module} from ${was}" );
219             }
220              
221             if ($module) {
222             not exists $dists{ $module }
223             and $dists{ $module } = $self->$_version_from_module( $module );
224             }
225             else { $result{ $used_key } = $used->{ $used_key } }
226             }
227              
228             $result{ $_ } = $dists{ $_ } for (keys %dists);
229              
230             return \%result;
231             };
232              
233             my $_dependencies = sub {
234             my ($self, $paths) = @_; my $used = {};
235              
236             for my $path (@{ $paths }) {
237             my $lines = $_read_non_pod_lines->( $path );
238              
239             for my $line (split m{ \n }mx, $lines) {
240             my $modules = $_parse_depends_line->( $line ); $modules->[ 0 ] or next;
241              
242             for (@{ $modules }) {
243             $_looks_like_version->( $_ ) and $used->{perl} = $_ and next;
244              
245             not exists $used->{ $_ }
246             and $used->{ $_ } = $self->$_version_from_module( $_ );
247             }
248             }
249             }
250              
251             return $used;
252             };
253              
254             my $_filter_dependents = sub {
255             my ($self, $used) = @_; my $excludes = 't::boilerplate';
256              
257             my $perl_version = $used->{perl} // 5.008_008;
258             my $core_modules = $Module::CoreList::version{ $perl_version };
259             my $provides = $self->load_meta->provides;
260              
261             return $self->$_consolidate( { map { $_ => $used->{ $_ } }
262             grep { not exists $core_modules->{ $_ } }
263             grep { not exists $provides->{ $_ } }
264             grep { not m{ \A $excludes \z }mx }
265             keys %{ $used } } );
266             };
267              
268             sub _filter_build_requires_paths {
269 0           return [ grep { m{ (?: \.pm | \.t ) \z }mx }
270 0     0     grep { m{ \A t \b }mx } @{ $_[ 1 ] } ];
  0            
  0            
271             }
272              
273             sub _filter_configure_requires_paths {
274 0     0     my $file = $_[ 0 ]->project_file;
275              
276 0 0         return [ grep { m{ \A inc }mx || $_ eq $file } @{ $_[ 1 ] } ];
  0            
  0            
277             }
278              
279             sub _filter_requires_paths {
280 0     0     my $file = $_[ 0 ]->project_file;
281 0 0         my $pattern = $file eq 'dist.ini' ? '(?: Build.PL | Makefile.PL )' : $file;
282              
283 0   0       return [ grep { not m{ \A (?: inc | t ) \b }mx
284 0           and not m{ \A $pattern \z }mx } @{ $_[ 1 ] } ];
  0            
285             }
286              
287             # Public methods
288             sub prereq_diffs : method {
289 0     0 1   my $self = shift;
290              
291 0           ensure_class_loaded 'CPAN';
292 0           ensure_class_loaded 'Module::CoreList';
293 0           ensure_class_loaded 'Pod::Eventual::Simple';
294              
295 0   0       my $field = $self->next_argv // 'requires';
296 0           my $filter = "_filter_${field}_paths";
297 0           my $sources = $self->$filter( $self->$_source_paths );
298 0           my $depends = $self->$_filter_dependents( $self->$_dependencies( $sources ));
299              
300 0           $_emit_diffs->( $self->$_compare_prereqs_with_used( $field, $depends ) );
301 0           return OK;
302             }
303              
304             1;
305              
306             __END__
307              
308             =pod
309              
310             =encoding utf8
311              
312             =head1 Name
313              
314             Module::Provision::TraitFor::PrereqDifferences - Displays a prerequisite difference report
315              
316             =head1 Synopsis
317              
318             use Moose;
319              
320             extends 'Module::Provision::Base';
321             with 'Module::Provision::TraitFor::PrereqDifferences';
322              
323             =head1 Description
324              
325             Displays a prerequisite difference report
326              
327             =head1 Configuration and Environment
328              
329             Defines no attributes
330              
331             =head1 Subroutines/Methods
332              
333             =head2 prereq_diffs - Displays a prerequisite difference report
334              
335             $exit_code = $self->prereq_diffs;
336              
337             Shows which dependencies should be added to, removed from, or updated
338             in the the distributions project file
339              
340             =head1 Diagnostics
341              
342             None
343              
344             =head1 Dependencies
345              
346             =over 3
347              
348             =item L<Class::Usul>
349              
350             =item L<CPAN>
351              
352             =item L<Module::CoreList>
353              
354             =item L<Moose::Role>
355              
356             =item L<Pod::Eventual::Simple>
357              
358             =back
359              
360             =head1 Incompatibilities
361              
362             There are no known incompatibilities in this module
363              
364             =head1 Bugs and Limitations
365              
366             There are no known bugs in this module.
367             Please report problems to the address below.
368             Patches are welcome
369              
370             =head1 Acknowledgements
371              
372             Larry Wall - For the Perl programming language
373              
374             =head1 Author
375              
376             Peter Flanigan, C<< <pjfl@cpan.org> >>
377              
378             =head1 License and Copyright
379              
380             Copyright (c) 2017 Peter Flanigan. All rights reserved
381              
382             This program is free software; you can redistribute it and/or modify it
383             under the same terms as Perl itself. See L<perlartistic>
384              
385             This program is distributed in the hope that it will be useful,
386             but WITHOUT WARRANTY; without even the implied warranty of
387             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE
388              
389             =cut
390              
391             # Local Variables:
392             # mode: perl
393             # tab-width: 3
394             # End: