File Coverage

lib/Perl/PrereqScanner/NotQuiteLite/Util/CPANfile.pm
Criterion Covered Total %
statement 79 79 100.0
branch 26 28 92.8
condition 6 7 85.7
subroutine 10 10 100.0
pod 1 2 50.0
total 122 126 96.8


line stmt bran cond sub pod time code
1             package Perl::PrereqScanner::NotQuiteLite::Util::CPANfile;
2              
3 3     3   676 use strict;
  3         5  
  3         69  
4 3     3   11 use warnings;
  3         4  
  3         64  
5 3     3   406 use parent 'Module::CPANfile';
  3         223  
  3         14  
6 3     3   17382 use Perl::PrereqScanner::NotQuiteLite::Util::Prereqs;
  3         7  
  3         2093  
7              
8             sub load_and_merge {
9 15     15 0 45 my ($class, $file, $prereqs, $features) = @_;
10              
11 15 50       63 $prereqs = $prereqs->as_string_hash unless ref $prereqs eq 'HASH';
12              
13 15         6907 my $self;
14 15 100       242 if (-f $file) {
15 6         47 $self = $class->load($file);
16 6         338 $self->_merge_prereqs($prereqs);
17             } else {
18 9         60 $self = $class->from_prereqs($prereqs);
19             }
20              
21 15 100       839 if ($features) {
22 9         22 for my $identifier (keys %$features) {
23 9         17 my $feature = $features->{$identifier};
24 9 100       36 next unless $feature->{prereqs};
25 8 100       59 $self->_merge_prereqs($feature->{prereqs}, $identifier) or next;
26 7         27 $self->{_prereqs}->add_feature($identifier, $feature->{description});
27             }
28             }
29              
30 15         71 $self->_dedupe;
31              
32 15         52 $self;
33             }
34              
35             sub features {
36 15     15 1 60 my $self = shift;
37 15         46 map $self->feature($_), sort $self->{_prereqs}->identifiers; # TWEAKED
38             }
39              
40             sub _merge_prereqs {
41 14     14   34 my ($self, $prereqs, $feature_id) = @_;
42 14 100       52 $prereqs = $prereqs->as_string_hash unless ref $prereqs eq 'HASH';
43              
44 14         3527 my $current = CPAN::Meta::Prereqs->new($self->{_prereqs}->specs($feature_id));
45 14         1448 my $merged = $current->with_merged_prereqs(CPAN::Meta::Prereqs->new($prereqs));
46              
47 14         6671 $self->__replace_prereqs($merged, $feature_id);
48             }
49              
50             sub __replace_prereqs {
51 37     37   72 my ($self, $prereqs, $feature_id) = @_;
52 37 50       103 $prereqs = $prereqs->as_string_hash unless ref $prereqs eq 'HASH';
53              
54 37   100     4879 @{$self->{_prereqs}{prereqs}{$feature_id || ''}} = ();
  37         209  
55 37         61 my $added = 0;
56 37         80 for my $phase (keys %$prereqs) {
57 33         46 for my $type (keys %{$prereqs->{$phase}}) {
  33         64  
58 33         53 while (my($module, $requirement) = each %{$prereqs->{$phase}{$type}}) {
  98         283  
59             $self->{_prereqs}->add(
60 65         159 feature => $feature_id,
61             phase => $phase,
62             type => $type,
63             module => $module,
64             requirement => Module::CPANfile::Requirement->new(name => $module, version => $requirement),
65             );
66 65         1127 $added++
67             }
68             }
69             }
70 37 100       82 delete $self->{_prereqs}{cpanmeta} unless $feature_id; # to rebuild cpanmeta
71 37         172 $added;
72             }
73              
74             sub _dedupe {
75 15     15   28 my $self = shift;
76 15         44 my $prereqs = $self->prereqs;
77 15         2577 my %features = map {$_ => $self->feature($_)->{prereqs} } $self->{_prereqs}->identifiers;
  8         86  
78              
79 15         3235 dedupe_prereqs_and_features($prereqs, \%features);
80              
81 15         72 $self->__replace_prereqs($prereqs);
82 15         51 for my $feature_id (keys %features) {
83 8         17 $self->__replace_prereqs($features{$feature_id}, $feature_id);
84             }
85             }
86              
87             sub _dump_prereqs {
88 23     23   21295 my($self, $prereqs, $include_empty, $base_indent) = @_;
89              
90 23         39 my $code = '';
91 23         66 my @x_phases = sort grep {/^x_/i} keys %$prereqs; # TWEAKED
  21         75  
92 23         51 for my $phase (qw(runtime configure build test develop), @x_phases) {
93 116 100       195 my $indent = $phase eq 'runtime' ? '' : ' ';
94 116   100     281 $indent = (' ' x ($base_indent || 0)) . $indent;
95              
96 116         165 my($phase_code, $requirements);
97 116 100       208 $phase_code .= "on $phase => sub {\n" unless $phase eq 'runtime';
98              
99 116         183 my @x_types = sort grep {/^x_/i} keys %{$prereqs->{$phase}}; # TWEAKED
  21         64  
  116         241  
100 116         173 for my $type (qw(requires recommends suggests conflicts), @x_types) {
101 464         519 for my $mod (sort keys %{$prereqs->{$phase}{$type}}) {
  464         944  
102 43         79 my $ver = $prereqs->{$phase}{$type}{$mod};
103 43 100       106 $phase_code .= $ver eq '0'
104             ? "${indent}$type '$mod';\n"
105             : "${indent}$type '$mod', '$ver';\n";
106 43         71 $requirements++;
107             }
108             }
109              
110 116 100       220 $phase_code .= "\n" unless $requirements;
111 116 100       179 $phase_code .= "};\n" unless $phase eq 'runtime';
112              
113 116 100 66     291 $code .= $phase_code . "\n" if $requirements or $include_empty;
114             }
115              
116 23         103 $code =~ s/\n+$/\n/s;
117 23         66 $code;
118             }
119              
120             1;
121              
122             __END__