File Coverage

lib/Perl/PrereqScanner/NotQuiteLite/App.pm
Criterion Covered Total %
statement 261 338 77.2
branch 119 202 58.9
condition 38 80 47.5
subroutine 25 31 80.6
pod 3 3 100.0
total 446 654 68.2


line stmt bran cond sub pod time code
1             package Perl::PrereqScanner::NotQuiteLite::App;
2              
3 59     59   33846 use strict;
  59         146  
  59         1891  
4 59     59   337 use warnings;
  59         129  
  59         1730  
5 59     59   323 use File::Find;
  59         128  
  59         4064  
6 59     59   385 use File::Glob 'bsd_glob';
  59         157  
  59         5593  
7 59     59   418 use File::Basename;
  59         129  
  59         3153  
8 59     59   342 use File::Spec;
  59         129  
  59         1088  
9 59     59   24635 use CPAN::Meta::Prereqs;
  59         102298  
  59         1802  
10 59     59   409 use CPAN::Meta::Requirements;
  59         130  
  59         1051  
11 59     59   320 use Perl::PrereqScanner::NotQuiteLite;
  59         145  
  59         1407  
12 59     59   23555 use Perl::PrereqScanner::NotQuiteLite::Util::Prereqs;
  59         173  
  59         3067  
13 59     59   23262 use Parse::Distname;
  59         107815  
  59         3283  
14              
15 59     59   436 use constant WIN32 => $^O eq 'MSWin32';
  59         127  
  59         243784  
16              
17             my %IsTestClassFamily = map {$_ => 1} qw(
18             Test::Class
19             Test::Class::Moose
20             Test::Class::Most
21             Test::Class::Sugar
22             Test::Classy
23             );
24              
25             sub new {
26 43     43 1 211187 my ($class, %opts) = @_;
27              
28 43         228 for my $key (keys %opts) {
29 218 50       638 next unless $key =~ /\-/;
30 0         0 (my $replaced_key = $key) =~ s/\-/_/g;
31 0         0 $opts{$replaced_key} = $opts{$key};
32             }
33              
34 43         455 $opts{prereqs} = CPAN::Meta::Prereqs->new;
35 43 50       1973 $opts{parsers} = [':bundled'] unless defined $opts{parsers};
36 43 50       162 $opts{recommends} = 0 unless defined $opts{recommends};
37 43 50       139 $opts{suggests} = 0 unless defined $opts{suggests};
38 43   33     159 $opts{base_dir} ||= File::Spec->curdir;
39              
40 43 100       172 $opts{cpanfile} = 1 if $opts{save_cpanfile};
41              
42 43 100 66     220 if ($opts{features} and ref $opts{features} ne 'HASH') {
43 12         29 my @features;
44 12 100       46 if (!ref $opts{features}) {
    50          
45 10         47 @features = split ';', $opts{features};
46             } elsif (ref $opts{features} eq 'ARRAY') {
47 2         5 @features = @{$opts{features}};
  2         8  
48             }
49 12         25 my %map;
50 12         33 for my $spec (@features) {
51 12         54 my ($identifier, $description, $paths) = split ':', $spec;
52 12         39 my @paths = map { bsd_glob(File::Spec->catdir($opts{base_dir}, $_)) } split ',', $paths;
  12         441  
53 12         41 if (WIN32) {
54             s|\\|/|g for @paths;
55             }
56 12         90 $map{$identifier} = {
57             description => $description,
58             paths => \@paths,
59             };
60             }
61 12         45 $opts{features} = \%map;
62             }
63              
64 43 100 66     190 if ($opts{ignore} and ref $opts{ignore} eq 'ARRAY') {
65 2         15 require Regexp::Trie;
66 2         17 my $re = Regexp::Trie->new;
67 2         13 for (@{$opts{ignore}}) {
  2         9  
68 2         4 s|\\|/|g if WIN32;
69 2         9 $re->add($_);
70             }
71 2   33     142 $opts{ignore_re} ||= $re->_regexp;
72             }
73              
74 43 100 66     807 if ($opts{private} and ref $opts{private} eq 'ARRAY') {
75 1         7 require Regexp::Trie;
76 1         8 my $re = Regexp::Trie->new;
77 1         6 for (@{$opts{private}}) {
  1         3  
78 1         5 $re->add($_);
79             }
80 1   33     52 $opts{private_re} ||= $re->_regexp;
81             }
82              
83 43 100 66     390 if ($opts{optional} and ref $opts{optional} eq 'ARRAY') {
84 2         16 require Regexp::Trie;
85 2         20 my $re = Regexp::Trie->new;
86 2         11 for (@{$opts{optional}}) {
  2         7  
87 2         4 s|\\|/|g if WIN32;
88 2         7 $re->add($_);
89             }
90 2   33     139 $opts{optional_re} ||= $re->_regexp;
91             }
92 43 100       797 if ($opts{optional_re}) {
93 3         9 $opts{suggests} = 1;
94             }
95              
96 43 50       152 if (my $index_name = delete $opts{use_index}) {
97 0         0 my $index_package = "CPAN::Common::Index::$index_name";
98 0 0       0 if (eval "require $index_package; 1") {
99 0         0 $opts{index} = $index_package->new;
100             }
101             }
102              
103 43 100       132 if ($opts{scan_also}) {
104 2   33     15 $opts{libs} ||= delete $opts{scan_also};
105             }
106              
107 43         197 bless \%opts, $class;
108             }
109              
110             sub run {
111 43     43 1 129 my ($self, @args) = @_;
112              
113 43 50       160 unless (@args) {
114             # for configure requires
115 43         121 push @args, "Makefile.PL", "Build.PL";
116              
117             # for test requires
118 43         103 push @args, "t";
119              
120             # for runtime requires;
121 43 50 33     241 if ($self->{blib} and -d File::Spec->catdir($self->{base_dir}, 'blib')) {
122 0         0 push @args, "blib/lib", "blib/bin", "blib/script";
123             } else {
124 43         106 push @args, "lib";
125 43         3126 push @args, glob(File::Spec->catfile($self->{base_dir}, '*.pm'));
126 43         298 push @args, "bin", "script", "scripts";
127             }
128              
129             # extra libs
130 43 100       104 push @args, map { bsd_glob(File::Spec->catdir($self->{base_dir}, $_)) } @{$self->{libs} || []};
  2         88  
  43         327  
131              
132             # for develop requires
133 43 50       193 push @args, "xt", "author" if $self->{develop};
134             }
135              
136 43 50       156 if ($self->{verbose}) {
137 0         0 print STDERR "Scanning the following files/directories\n";
138 0         0 print STDERR " $_\n" for sort @args;
139             }
140              
141 43         121 for my $path (@args) {
142 337 100       4043 my $item = File::Spec->file_name_is_absolute($path) ? $path : File::Spec->catfile($self->{base_dir}, $path);
143 337 100       6908 -d $item ? $self->_scan_dir($item) :
    100          
144             -f $item ? $self->_scan_file($item) :
145             next;
146             }
147              
148             # add test requirements by .pm files used in .t files
149 43         360 $self->_add_test_requires($self->{allow_test_pms});
150              
151 43         295 $self->_exclude_local_modules;
152              
153 43 100       142 if ($self->{exclude_core}) {
154 7         27 $self->_exclude_core_prereqs;
155             }
156              
157 43 50       815 if ($self->{index}) {
158 0         0 $self->_dedupe_indexed_prereqs;
159             }
160              
161 43         180 $self->_dedupe;
162              
163 43 100 66     324 if ($self->{print} or $self->{cpanfile}) {
164 15 50       59 if ($self->{json}) {
    50          
    0          
165             # TODO: feature support (how should we express it?)
166 0 0       0 eval { require JSON::PP } or die "requires JSON::PP";
  0         0  
167 0         0 print JSON::PP->new->pretty(1)->canonical->encode($self->{prereqs}->as_string_hash);
168             } elsif ($self->{cpanfile}) {
169 15 50       33 eval { require Perl::PrereqScanner::NotQuiteLite::Util::CPANfile } or die "requires Module::CPANfile";
  15         1082  
170 15         196 my $file = File::Spec->catfile($self->{base_dir}, "cpanfile");
171 15         176 my $cpanfile = Perl::PrereqScanner::NotQuiteLite::Util::CPANfile->load_and_merge($file, $self->{prereqs}, $self->{features});
172              
173 15 50       82 $self->_dedupe_indexed_prereqs($cpanfile->prereqs) if $self->{index};
174              
175 15 50       50 if ($self->{save_cpanfile}) {
    0          
176 15         63 $cpanfile->save($file);
177             } elsif ($self->{print}) {
178 0         0 print $cpanfile->to_string, "\n";
179             }
180 15         673692 return $cpanfile;
181             } elsif ($self->{print}) {
182 0         0 $self->_print_prereqs;
183             }
184             }
185 28         163 $self->{prereqs};
186             }
187              
188 0     0 1 0 sub index { shift->{index} }
189              
190             sub _print_prereqs {
191 0     0   0 my $self = shift;
192              
193 0         0 my $combined = CPAN::Meta::Requirements->new;
194              
195 0         0 for my $req ($self->_requirements) {
196 0         0 $combined->add_requirements($req);
197             }
198 0         0 my $hash = $combined->as_string_hash;
199 0         0 for my $module (sort keys %$hash) {
200 0 0       0 next if $module eq 'perl';
201 0   0     0 my $version = $hash->{$module} || 0;
202 0 0       0 $version = qq{"$version"} unless $version =~ /^[0-9]+(?:\.[0-9]+)?$/;
203 0 0       0 print $version eq '0' ? "$module\n" : "$module~$version\n";
204             }
205             }
206              
207             sub _requirements {
208 56     56   169 my ($self, $prereqs) = @_;
209              
210 56   33     329 $prereqs ||= $self->{prereqs};
211 56         196 my @phases = qw/configure runtime build test/;
212 56 50       184 push @phases, 'develop' if $self->{develop};
213 56 0       235 my @types = $self->{suggests} ? qw/requires recommends suggests/ : $self->{recommends} ? qw/requires recommends/ : qw/requires/;
    50          
214 56         107 my @requirements;
215 56         318 for my $phase (@phases) {
216 224         1130 for my $type (@types) {
217 672         3133 my $req = $prereqs->requirements_for($phase, $type);
218 672 100       24020 next unless $req->required_modules;
219 59         413 push @requirements, $req;
220             }
221             }
222              
223 56 100       436 if ($self->{features}) {
224 18 50       38 my @feature_prereqs = grep defined, map {$self->{features}{$_}{prereqs}} keys %{$self->{features} || {}};
  18         71  
  18         100  
225 18         47 for my $feature_prereqs (@feature_prereqs) {
226 15         32 for my $phase (@phases) {
227 60         288 for my $type (@types) {
228 180         884 my $req = $feature_prereqs->requirements_for($phase, $type);
229 180 100       6274 next unless $req->required_modules;
230 18         226 push @requirements, $req;
231             }
232             }
233             }
234             }
235              
236 56         274 @requirements;
237             }
238              
239             sub _exclude_local_modules {
240 43     43   287 my $self = shift;
241              
242 43 100       176 my @local_dirs = ("inc", @{$self->{libs} || []});
  43         275  
243 43         130 for my $dir (@local_dirs) {
244 45         455 my $local_dir = File::Spec->catdir($self->{base_dir}, $dir);
245 45 100       830 next unless -d $local_dir;
246             find({
247             wanted => sub {
248 6     6   23 my $file = $_;
249 6 100       361 return unless -f $file;
250 2         134 my $relpath = File::Spec->abs2rel($file, $local_dir);
251              
252 2 50       17 return unless $relpath =~ /\.pm$/;
253 2         6 my $module = $relpath;
254 2         10 $module =~ s!\.pm$!!;
255 2         13 $module =~ s![\\/]!::!g;
256 2         8 $self->{possible_modules}{$module} = 1;
257 2 100       39 $self->{possible_modules}{"inc::$module"} = 1 if $dir eq 'inc';
258             },
259 2         140 no_chdir => 1,
260             }, $local_dir);
261             }
262              
263 43         161 my $private_re = $self->{private_re};
264 43         544 for my $req ($self->_requirements) {
265 60         160 for my $module ($req->required_modules) {
266 164 100 100     932 next unless $self->{possible_modules}{$module} or ($private_re and $module =~ /$private_re/);
      100        
267 8         32 $req->clear_requirement($module);
268 8 50       154 if ($self->{verbose}) {
269 0         0 print STDERR " excluded $module (local)\n";
270             }
271             }
272             }
273             }
274              
275             sub _exclude_core_prereqs {
276 7     7   16 my $self = shift;
277              
278 7 50       13 eval { require Module::CoreList; Module::CoreList->VERSION('2.99') } or die "requires Module::CoreList 2.99";
  7         5895  
  7         202187  
279              
280 7   100     46 my $perl_version = $self->{perl_version} || $self->_find_used_perl_version || '5.008001';
281 7 100       275 if ($perl_version =~ /^v?5\.(0?[1-9][0-9]?)(?:\.([0-9]))?$/) {
282 1   50     13 $perl_version = sprintf '5.%03d%03d', $1, $2 || 0;
283             }
284 7 50       36 $perl_version = '5.008001' unless exists $Module::CoreList::version{$perl_version};
285              
286 7         56 my %core_alias = (
287             'Getopt::Long::Parser' => 'Getopt::Long',
288             'Tie::File::Cache' => 'Tie::File',
289             'Tie::File::Heap' => 'Tie::File',
290             'Tie::StdScalar' => 'Tie::Scalar',
291             'Tie::StdArray' => 'Tie::Array',
292             'Tie::StdHash' => 'Tie::Hash',
293             'Tie::ExtraHash' => 'Tie::Hash',
294             'Tie::RefHash::Nestable' => 'Tie::RefHash',
295             );
296              
297 7         20 for my $req ($self->_requirements) {
298 9         25 for my $module ($req->required_modules) {
299 30 50       2094 $module = $core_alias{$module} if exists $core_alias{$module};
300 30 100 66     87 if (Module::CoreList::is_core($module, undef, $perl_version) and
301             !Module::CoreList::deprecated_in($module, undef, $perl_version)
302             ) {
303 22 50       91783 next unless exists $Module::CoreList::version{$perl_version}{$module};
304 22         60 my $core_version = $Module::CoreList::version{$perl_version}{$module};
305 22 100       77 next unless $req->accepts_module($module => $core_version);
306 21         1489 $req->clear_requirement($module);
307 21 50       341 if ($self->{verbose}) {
308 0         0 print STDERR " excluded $module ($perl_version core)\n";
309             }
310             }
311             }
312             }
313             }
314              
315             sub _find_used_perl_version {
316 6     6   17 my $self = shift;
317 6         25 my @perl_versions;
318 6         34 my $perl_requirements = CPAN::Meta::Requirements->new;
319 6         107 for my $req ($self->_requirements) {
320 8         27 my $perl_req = $req->requirements_for_module('perl');
321 8 100       129 $perl_requirements->add_string_requirement('perl', $perl_req) if $perl_req;
322             }
323 6 50       169 return $perl_requirements->is_simple ? $perl_requirements->requirements_for_module('perl') : undef;
324             }
325              
326             sub _add_test_requires {
327 43     43   263 my ($self, $force) = @_;
328              
329 43 50       207 if (my $test_reqs = $self->{prereqs}->requirements_for('test', 'requires')) {
330 43         2315 my @required_modules = $test_reqs->required_modules;
331 43         426 for my $module (@required_modules) {
332 10 100       258 $force = 1 if exists $IsTestClassFamily{$module};
333 10 100       31 my $relpath = $self->{possible_modules}{$module} or next;
334 3 50       13 my $context = delete $self->{_test_pm}{$relpath} or next;
335 3         12 $test_reqs->add_requirements($context->requires);
336 3 50 33     361 if ($self->{recommends} or $self->{suggests}) {
337 3         13 $self->{prereqs}->requirements_for('test', 'recommends')->add_requirements($context->recommends);
338             }
339 3 50       31 if ($self->{suggests}) {
340 3         70 $self->{prereqs}->requirements_for('test', 'suggests')->add_requirements($context->suggests);
341             }
342             }
343 43 100       175 if ($force) {
344 2 50       5 for my $context (values %{$self->{_test_pm} || {}}) {
  2         11  
345 2         9 $test_reqs->add_requirements($context->requires);
346 2 50 33     243 if ($self->{recommends} or $self->{suggests}) {
347 2         9 $self->{prereqs}->requirements_for('test', 'recommends')->add_requirements($context->recommends);
348             }
349 2 50       20 if ($self->{suggests}) {
350 2         7 $self->{prereqs}->requirements_for('test', 'suggests')->add_requirements($context->suggests);
351             }
352             }
353             }
354             }
355             }
356              
357             sub _dedupe {
358 43     43   96 my $self = shift;
359              
360 43         97 my $prereqs = $self->{prereqs};
361              
362 43 100       85 my %features = map {$_ => $self->{features}{$_}{prereqs}} keys %{$self->{features} || {}};
  12         49  
  43         239  
363              
364 43         250 dedupe_prereqs_and_features($prereqs, \%features);
365             }
366              
367             sub _get_uri {
368 0     0   0 my ($self, $module) = @_;
369 0   0     0 $self->{uri_cache}{$module} ||= $self->__get_uri($module);
370             }
371              
372             sub __get_uri {
373 0     0   0 my ($self, $module) = @_;
374 0 0       0 my $res = $self->{index}->search_packages({ package => $module }) or return;
375             ## ignore (non-dual) core modules
376 0 0       0 return if _dist_from_uri($res->{uri}) eq 'perl';
377 0         0 return $res->{uri};
378             }
379              
380             sub _dist_from_uri {
381 0     0   0 my $uri = shift;
382 0         0 $uri =~ s!^cpan:///\w+/!!;
383 0         0 Parse::Distname->new($uri)->dist;
384             }
385              
386             sub _dedupe_indexed_prereqs {
387 0     0   0 my ($self, $prereqs) = @_;
388              
389 0         0 for my $req ($self->_requirements($prereqs)) {
390 0         0 my %uri_map;
391 0         0 for my $module ($req->required_modules) {
392 0 0       0 next if $module eq 'perl';
393 0 0       0 my $uri = $self->_get_uri($module) or next;
394 0         0 $uri_map{$uri}{$module} = $req->requirements_for_module($module);
395             }
396 0         0 for my $uri (keys %uri_map) {
397 0         0 my @modules = keys %{$uri_map{$uri}};
  0         0  
398 0 0       0 next if @modules < 2;
399              
400 0         0 my @modules_without_version = grep {!$uri_map{$uri}{$_}} @modules;
  0         0  
401 0 0       0 next unless @modules_without_version;
402              
403             # clear unversioned prereqs if a versioned prereq exists
404 0 0       0 if (@modules > @modules_without_version) {
405 0         0 $req->clear_requirement($_) for @modules_without_version;
406 0         0 next;
407             }
408              
409             # Replace with the main module if none is versioned
410 0         0 my $dist = _dist_from_uri($uri);
411 0         0 (my $main_module = $dist) =~ s/-/::/g;
412 0 0       0 if ($self->_get_uri($main_module)) {
413 0         0 $req->add_minimum($main_module);
414 0         0 for my $module (@modules_without_version) {
415 0 0       0 next if $main_module eq $module;
416 0         0 $req->clear_requirement($module);
417 0 0       0 if ($self->{verbose}) {
418 0         0 print STDERR " deduped $module (in favor of $main_module)\n";
419             }
420             }
421             } else {
422             # special case for distributions without a main module
423 0         0 my %score;
424 0         0 for my $module (@modules_without_version) {
425 0         0 my $depth = $module =~ s/::/::/g;
426 0         0 my $length = length $module;
427 0   0     0 $score{$module} = join ".", ($depth || 0), $length;
428             }
429 0 0       0 my $topmost = (sort {$score{$a} <=> $score{$b} or $a cmp $b} @modules_without_version)[0];
  0         0  
430 0         0 for my $module (@modules_without_version) {
431 0 0       0 next if $topmost eq $module;
432 0         0 $req->clear_requirement($module);
433 0 0       0 if ($self->{verbose}) {
434 0         0 print STDERR " deduped $module (in favor of $topmost)\n";
435             }
436             }
437             }
438             }
439             }
440             }
441              
442             sub _scan_dir {
443 22     22   88 my ($self, $dir) = @_;
444             find ({
445             no_chdir => 1,
446             wanted => sub {
447 87     87   289 my $file = $_;
448 87 100       4590 return unless -f $file;
449 42         2634 my $relpath = File::Spec->abs2rel($file, $self->{base_dir});
450              
451             return unless $relpath =~ /\.(?:pl|PL|pm|cgi|psgi|t)$/ or
452             dirname($relpath) =~ m!\b(?:bin|scripts?)$! or
453 42 0 33     360 ($self->{develop} and $relpath =~ /^(?:author)\b/);
      0        
      33        
454 42         153 $self->_scan_file($file);
455             },
456 22         2145 }, $dir);
457             }
458              
459             sub _scan_file {
460 75     75   240 my ($self, $file) = @_;
461              
462 75         129 $file =~ s|\\|/|g if WIN32;
463 75 100       242 if ($self->{ignore_re}) {
464 6 100       145 return if $file =~ /\b$self->{ignore_re}\b/;
465             }
466              
467 72 100 100     347 my $optional = $self->{optional_re} && $file =~ /\b$self->{optional_re}\b/ ? 1 : 0;
468              
469             my $context = Perl::PrereqScanner::NotQuiteLite->new(
470             parsers => $self->{parsers},
471             recommends => $self->{recommends},
472             suggests => $self->{suggests},
473             verbose => $self->{verbose},
474 72         712 optional => $optional,
475             )->scan_file($file);
476              
477 72         8154 my $relpath = File::Spec->abs2rel($file, $self->{base_dir});
478 72         232 $relpath =~ s|\\|/|g if WIN32;
479              
480 72         165 my $prereqs = $self->{prereqs};
481 72 100       238 if ($self->{features}) {
482 22         41 for my $identifier (keys %{$self->{features}}) {
  22         96  
483 22         46 my $feature = $self->{features}{$identifier};
484 22 100       41 if (grep {$file =~ m!^$_(?:/|$)!} @{$feature->{paths}}) {
  25         479  
  22         51  
485 12   66     117 $prereqs = $feature->{prereqs} ||= CPAN::Meta::Prereqs->new;
486 12         790 last;
487             }
488             }
489             }
490              
491 72 100       765 if ($relpath =~ m!(?:^|[\\/])t[\\/]!) {
    50          
    50          
    50          
492 10 100       50 if ($relpath =~ /\.t$/) {
    100          
493 3         13 $self->_add($prereqs, test => $context);
494             } elsif ($relpath =~ /\.pm$/) {
495 6         21 $self->{_test_pm}{$relpath} = $context;
496             }
497             } elsif ($relpath =~ m!(?:^|[\\/])(?:xt|inc|author)[\\/]!) {
498 0         0 $self->_add($prereqs, develop => $context);
499             } elsif ($relpath =~ m!(?:(?:^|[\\/])Makefile|^Build)\.PL$!) {
500 0         0 $self->_add($prereqs, configure => $context);
501             } elsif ($relpath =~ m!(?:^|[\\/])(?:.+)\.PL$!) {
502 0         0 $self->_add($prereqs, build => $context);
503             } else {
504 62         240 $self->_add($prereqs, runtime => $context);
505             }
506              
507 72 100       1917 if ($relpath =~ /\.pm$/) {
508 68         155 my $module = $relpath;
509 68         259 $module =~ s!\.pm$!!;
510 68         258 $module =~ s![\\/]!::!g;
511 68         261 $self->{possible_modules}{$module} = $relpath;
512 68         226 $module =~ s!^(?:inc|blib|x?t)::!!;
513 68         169 $self->{possible_modules}{$module} = $relpath;
514 68         177 $module =~ s!^lib::!!;
515 68         4146 $self->{possible_modules}{$module} = $relpath;
516             }
517             }
518              
519             sub _add {
520 65     65   194 my ($self, $prereqs, $phase, $context) = @_;
521              
522 65         286 $prereqs->requirements_for($phase, 'requires')
523             ->add_requirements($context->requires);
524              
525 65 50 33     8359 if ($self->{suggests} or $self->{recommends}) {
526 65         204 $prereqs->requirements_for($phase, 'recommends')
527             ->add_requirements($context->recommends);
528             }
529              
530 65 50       1112 if ($self->{suggests}) {
531 65         190 $prereqs->requirements_for($phase, 'suggests')
532             ->add_requirements($context->suggests);
533             }
534             }
535              
536             1;
537              
538             __END__