File Coverage

blib/lib/PPM/Make/Search.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             package PPM::Make::Search;
2 2     2   15163 use strict;
  2         2  
  2         44  
3 2     2   5 use warnings;
  2         2  
  2         44  
4 2     2   406 use PPM::Make::Config qw(WIN32 HAS_CPAN HAS_PPM HAS_MB);
  2         4  
  2         139  
5 2     2   426 use PPM::Make::Util qw(:all);
  0            
  0            
6              
7             our $VERSION = '0.9903';
8             our ($ERROR);
9              
10             sub new {
11             my ($class, %opts) = @_;
12             my $self = {%opts,
13             query => undef,
14             args => {},
15             todo => [],
16             mod_results => {},
17             dist_results => {},
18             dist_id => {},
19             };
20             bless $self, $class;
21             }
22              
23             sub search {
24             my ($self, $query, %args) = @_;
25              
26             return if $self->{no_remote_lookup};
27              
28             unless ($query) {
29             $ERROR = q{Please specify a query term};
30             return;
31             }
32             $self->{query} = $query;
33             $self->{args} = \%args;
34             $self->{todo} = ref($query) eq 'ARRAY' ? $query : [$query];
35             my $mode = $args{mode};
36             unless ($mode) {
37             $ERROR = q{Please specify a mode within the search() method};
38             return;
39             }
40             if ($mode eq 'dist') {
41             return $self->dist_search(%args);
42             }
43             if ($mode eq 'mod') {
44             return $self->mod_search(%args);
45             }
46             $ERROR = q{Only 'mod' or 'dist' modes are supported};
47             return;
48             }
49              
50             sub mod_search {
51             my $self = shift;
52             if (defined $self->{cpan_meta} or HAS_CPAN) {
53             return 1 if $self->cpan_mod_search();
54             }
55             $ERROR = q{Not all query terms returned a result};
56             return 0;
57             }
58              
59             sub cpan_mod_search {
60             my $self = shift;
61             my @mods = @{$self->{todo}};
62             my @todo = ();
63             my $cpan_meta = $self->{cpan_meta};
64             foreach my $m (@mods) {
65             my $obj;
66             if ($cpan_meta) {
67             $obj = $cpan_meta->instance('CPAN::Module', $m);
68             } else {
69             $obj = CPAN::Shell->expand('Module', $m);
70             }
71             unless (defined $obj) {
72             push @todo, $m;
73             next;
74             }
75             my $mods = {};
76             my $string = $obj->as_string;
77             my $mod;
78             if ($string =~ /id\s*=\s*(.*?)\n/m) {
79             $mod = $1;
80             next unless $mod;
81             }
82             $mods->{mod_name} = $mod;
83             if (my $v = $obj->cpan_version) {
84             $mods->{mod_vers} = $v;
85             }
86             if ($string =~ /\s+DESCRIPTION\s+(.*?)\n/m) {
87             $mods->{mod_abs} = $1;
88             }
89             if ($string =~ /\s+CPAN_USERID.*\s+\((.*)\)\n/m) {
90             $mods->{author} = $1;
91             }
92             if ($string =~ /\s+CPAN_FILE\s+(\S+)\n/m) {
93             $mods->{dist_file} = $1;
94             }
95             ($mods->{cpanid} = $mods->{dist_file}) =~ s{\w/\w\w/(\w+)/.*}{$1};
96             $mods->{dist_name} = file_to_dist($mods->{dist_file});
97             $self->{mod_results}->{$mod} = $mods;
98             $self->{dist_id}->{$mods->{dist_name}} ||=
99             check_id($mods->{dist_file});
100             }
101             if (scalar @todo > 0) {
102             $self->{todo} = \@todo;
103             return;
104             }
105             $self->{todo} = [];
106             return 1;
107             }
108              
109             sub dist_search {
110             my $self = shift;
111             if (defined $self->{cpan_meta} or HAS_CPAN) {
112             return 1 if $self->cpan_dist_search();
113             }
114             $ERROR = q{Not all query terms returned a result};
115             return;
116             }
117              
118             sub cpan_dist_search {
119             my $self = shift;
120             my @dists = @{$self->{todo}};
121             my @todo = ();
122             my $cpan_meta = $self->{cpan_meta};
123             my $dist_id = $self->{dist_id};
124             foreach my $d (@dists) {
125             my $query = $dist_id->{$d}
126             || $self->guess_dist_from_mod($d)
127             || $self->dist_from_re($d);
128             unless (defined $query) {
129             push @todo, $d;
130             next;
131             }
132             my $obj;
133             if ($cpan_meta) {
134             $obj = $cpan_meta->instance('Distribution', $query);
135             } else {
136             $obj = CPAN::Shell->expand('Distribution', $query);
137             }
138             unless (defined $obj) {
139             push @todo, $d;
140             next;
141             }
142             my $dists = {};
143             my $string = $obj->as_string;
144             my $cpan_file;
145             if ($string =~ /id\s*=\s*(.*?)\n/m) {
146             $cpan_file = $1;
147             next unless $cpan_file;
148             }
149             my ($dist, $version) = file_to_dist($cpan_file);
150             $dists->{dist_name} = $dist;
151             $dists->{dist_file} = $cpan_file;
152             $dists->{dist_vers} = $version;
153             if ($string =~ /\s+CPAN_USERID.*\s+\((.*)\)\n/m) {
154             $dists->{author} = $1;
155             $dists->{cpanid} = $dists->{author};
156             }
157             $self->{dist_id}->{$dists->{dist_name}} ||=
158             check_id($dists->{dist_file});
159             my $mods;
160             if ($string =~ /\s+CONTAINSMODS\s+(.*)/m) {
161             $mods = $1;
162             }
163             next unless $mods;
164             my @mods = split ' ', $mods;
165             next unless @mods;
166             (my $try = $dist) =~ s{-}{::}g;
167             foreach my $mod(@mods) {
168             my $module;
169             if ($cpan_meta) {
170             $module = $cpan_meta->instance('Module', $mod);
171             } else {
172             $module = CPAN::Shell->expand('Module', $mod);
173             }
174             next unless $module;
175             if ($mod eq $try) {
176             my $desc = $module->description;
177             $dists->{dist_abs} = $desc if $desc;
178             }
179             my $v = $module->cpan_version;
180             $v = undef if $v eq 'undef';
181             if ($v) {
182             push @{$dists->{mods}}, {mod_name => $mod, mod_vers => $v};
183             }
184             else {
185             push @{$dists->{mods}}, {mod_name => $mod};
186             }
187             }
188             $self->{dist_results}->{$dist} = $dists;
189             }
190             if (scalar @todo > 0) {
191             $self->{todo} = \@todo;
192             return;
193             }
194             $self->{todo} = [];
195             return 1;
196             }
197              
198             sub guess_dist_from_mod {
199             my ($self, $dist) = @_;
200             my $query_save = $self->{query};
201             my $args_save = $self->{args};
202             my $todo_save = $self->{todo};
203             (my $try = $dist) =~ s{-}{::}g;
204             my $dist_file = '';
205             if ($self->search($try, mode => 'mod')) {
206             $dist_file = $self->{mod_results}->{$try}->{dist_file};
207             }
208             $self->{query} = $query_save;
209             $self->{args} = $args_save;
210             $self->{todo} = $todo_save;
211             return check_id($dist_file);
212             }
213              
214             sub dist_from_re {
215             my ($self, $d) = @_;
216             foreach my $match (CPAN::Shell->expand('Distribution', qq{/$d/})) {
217             my $string = $match->as_string;
218             my $cpan_file;
219             if ($string =~ /id\s*=\s*(.*?)\n/m) {
220             $cpan_file = $1;
221             next unless $cpan_file;
222             }
223             my $dist = file_to_dist($cpan_file);
224             if ($dist eq $d) {
225             return check_id($cpan_file);
226             }
227             }
228             return;
229             }
230              
231             sub search_error {
232             my ($self, $additional_error) = @_;
233             return if $self->{no_remote_lookup};
234             warn $ERROR;
235             warn $additional_error if $additional_error;
236             }
237              
238             sub check_id {
239             my $dist_file = shift;
240             if ($dist_file =~ m{^\w/\w\w/}) {
241             $dist_file =~ s{^\w/\w\w/}{};
242             }
243             return $dist_file;
244             }
245              
246             1;
247              
248             __END__