File Coverage

blib/lib/Carmel/Resolver.pm
Criterion Covered Total %
statement 15 76 19.7
branch 0 32 0.0
condition 0 9 0.0
subroutine 5 17 29.4
pod 0 9 0.0
total 20 143 13.9


line stmt bran cond sub pod time code
1             package Carmel::Resolver;
2 1     1   6 use strict;
  1         1  
  1         26  
3 1     1   4 use warnings;
  1         1  
  1         24  
4 1     1   4 use Class::Tiny qw( repo snapshot root seen found missing );
  1         3  
  1         5  
5              
6 1     1   3366 use Module::CoreList;
  1         90306  
  1         15  
7 1     1   1348 use Try::Tiny;
  1         1833  
  1         845  
8              
9             sub resolve {
10 0     0 0   my $self = shift;
11              
12 0           my $clone = $self->root->clone;
13 0           my $seen = {};
14 0           my $depth = 0;
15              
16 0           $self->resolve_recurse($clone, $seen, $depth);
17             }
18              
19             sub resolve_recurse {
20 0     0 0   my($self, $requirements, $seen, $depth) = @_;
21              
22 0           for my $module (sort $requirements->required_modules) {
23 0 0         next if $module eq 'perl';
24              
25 0           my $want_version = $self->root->requirements_for_module($module);
26 0           my $dist = $self->find_in_snapshot($module);
27              
28 0 0         $self->should_handle($module, $want_version, $dist)
29             or next;
30              
31 0           my $artifact;
32 0 0         if ($dist) {
33 0           $artifact = $self->repo->find_dist($module, $dist->name);
34             } else {
35 0     0     $artifact = $self->repo->find_match($module, sub { $self->accepts_all($self->root, $_[0]) });
  0            
36             }
37              
38             # FIXME there's a chance different version of the same module can be loaded here
39 0 0         if ($artifact) {
40 0 0         warn sprintf " %s (%s) in %s\n", $module, $artifact->version_for($module), $artifact->path if $Carmel::DEBUG;
41 0 0         next if $seen->{$artifact->path}++;
42 0           $self->found->($artifact, $depth);
43              
44 0           my $reqs = $artifact->requirements;
45 0           $self->merge_requirements($self->root, $reqs, $artifact->distname);
46              
47 0           $self->resolve_recurse($reqs, $seen, $depth + 1);
48             } else {
49 0 0         if ($dist) {
50             # TODO pass $dist->distfile to cpanfile
51 0           $want_version = $dist->version_for($module);
52             }
53 0           $self->missing->($module, $want_version, $depth);
54             }
55             }
56             }
57              
58             sub should_handle {
59 0     0 0   my($self, $module, $version, $dist) = @_;
60              
61             # not in core
62 0 0         return 1 unless $self->is_core($module);
63              
64             # core version doesn't satisfy the version
65 0 0         return 1 unless $self->core_satisfies($module, $version);
66              
67             # core, pinned, and the pinned version is lower than the core version:
68             # remove it from the snapshot and upgrade (#47)
69 0   0       return $dist &&
70             version::->parse($dist->version_for($module))
71             > version::->parse($self->core_version($module));
72             }
73              
74             sub core_version {
75 0     0 0   my($self, $module) = @_;
76 0   0       return $Module::CoreList::version{$]+0}{$module} || '0';
77             }
78              
79             sub is_core {
80 0     0 0   my($self, $module) = @_;
81 0           return exists $Module::CoreList::version{$]+0}{$module};
82             }
83              
84             sub core_satisfies {
85 0     0 0   my($self, $module, $want_version) = @_;
86 0 0         return unless exists $Module::CoreList::version{$]+0}{$module};
87              
88 0   0       my $version = $Module::CoreList::version{$]+0}{$module} || '0';
89 0           CPAN::Meta::Requirements->from_string_hash({ $module => $want_version })
90             ->accepts_module($module, $version);
91             }
92              
93             sub find_in_snapshot {
94 0     0 0   my($self, $module) = @_;
95              
96 0 0         my $snapshot = $self->snapshot or return;
97              
98 0 0         if (my $dist = $snapshot->find($module)) {
99 0 0         warn "@{[$dist->name]} found in snapshot for $module\n" if $Carmel::DEBUG;
  0            
100 0 0         if ($self->accepts_all($self->root, $dist)) {
101 0           return $dist;
102             }
103             }
104              
105 0 0         warn "$module not found in snapshot\n" if $Carmel::DEBUG;
106 0           return;
107             }
108              
109             sub accepts_all {
110 0     0 0   my($self, $reqs, $dist) = @_;
111              
112 0           for my $pkg (keys %{$dist->provides}) {
  0            
113 0   0       my $version = $dist->provides->{$pkg}{version} || '0';
114 0 0         return unless $reqs->accepts_module($pkg, $version);
115             }
116              
117 0           return 1;
118             }
119              
120             sub merge_requirements {
121 0     0 0   my($self, $reqs, $new_reqs, $where) = @_;
122              
123 0           for my $module ($new_reqs->required_modules) {
124 0           my $new = $new_reqs->requirements_for_module($module);
125             try {
126 0     0     $reqs->add_string_requirement($module, $new);
127             } catch {
128 0     0     my($err) = /illegal requirements(?: .*?): (.*) at/;
129 0           my $old = $reqs->requirements_for_module($module);
130 0           die "Found conflicting requirement for $module: '$old' <=> '$new' ($where): $err\n";
131 0           };
132             }
133             }
134              
135             1;