File Coverage

blib/lib/CPAN/UnsupportedFinder.pm
Criterion Covered Total %
statement 39 153 25.4
branch 11 48 22.9
condition 3 47 6.3
subroutine 8 23 34.7
pod 3 3 100.0
total 64 274 23.3


line stmt bran cond sub pod time code
1             package CPAN::UnsupportedFinder;
2              
3             # FIXME: magic dates should be configurable
4              
5 2     2   353256 use strict;
  2         3  
  2         54  
6 2     2   7 use warnings;
  2         2  
  2         76  
7              
8 2     2   9 use Carp;
  2         2  
  2         86  
9 2     2   1236 use HTTP::Tiny;
  2         118939  
  2         139  
10 2     2   1963 use Log::Log4perl;
  2         120784  
  2         9  
11 2     2   1278 use JSON::MaybeXS;
  2         24684  
  2         212  
12 2     2   18 use Scalar::Util;
  2         4  
  2         4156  
13              
14             =head1 NAME
15              
16             CPAN::UnsupportedFinder - Identify unsupported or poorly maintained CPAN modules
17              
18             =head1 DESCRIPTION
19              
20             CPAN::UnsupportedFinder analyzes CPAN modules for test results and maintenance status, flagging unsupported or poorly maintained distributions.
21              
22             =head1 VERSION
23              
24             Version 0.06
25              
26             =cut
27              
28             our $VERSION = '0.06';
29              
30             =head1 SYNOPSIS
31              
32             use CPAN::UnsupportedFinder;
33              
34             # Note use of hyphens not colons
35             my $finder = CPAN::UnsupportedFinder->new(verbose => 1);
36             my $results = $finder->analyze('Some-Module', 'Another-Module');
37              
38             for my $module (@$results) {
39             print "Module: $module->{module}\n";
40             print "Failure Rate: $module->{failure_rate}\n";
41             print "Last Update: $module->{last_update}\n";
42             }
43              
44             =head1 METHODS
45              
46             =head2 new
47              
48             Creates a new instance. Accepts the following arguments:
49              
50             =over 4
51              
52             =item * verbose
53              
54             Enable verbose output.
55              
56             =item * api_url
57              
58             metacpan URL, defaults to L<https://fastapi.metacpan.org/v1>
59              
60             =item * cpan_testers
61              
62             CPAN testers URL, detaults to L<https://api.cpantesters.org/api/v1>
63              
64             =item * logger
65              
66             Where to log messages, defaults to L<Log::Log4perl>
67              
68             =back
69              
70             =cut
71              
72             sub new {
73 7     7 1 300360 my $class = shift;
74              
75             # Handle hash or hashref arguments
76 7         14 my %args;
77 7 100 100     48 if((@_ == 1) && (ref $_[0] eq 'HASH')) {
    100          
78 1         3 %args = %{$_[0]};
  1         6  
79             } elsif((@_ % 2) == 0) {
80 5         13 %args = @_;
81             } else {
82 1         29 carp(__PACKAGE__, ': Invalid arguments passed to new()');
83 1         317 return;
84             }
85              
86 6 100       31 if(!defined($class)) {
    100          
87 1 50       6 if((scalar keys %args) > 0) {
88             # Using CPAN::UnsupportedFinder::new(), not CPAN::UnsupportedFinder->new()
89 0         0 carp(__PACKAGE__, ' use ->new() not ::new() to instantiate');
90 0         0 return;
91             }
92             # FIXME: this only works when no arguments are given
93 1         3 $class = __PACKAGE__;
94             } elsif(Scalar::Util::blessed($class)) {
95             # If $class is an object, clone it with new arguments
96 2         5 return bless { %{$class}, %args }, ref($class);
  2         23  
97             }
98              
99 4         41 my $self = {
100             api_url => 'https://fastapi.metacpan.org/v1',
101             cpan_testers => 'https://api.cpantesters.org/api/v1',
102             verbose => 0,
103             %args
104             };
105              
106 4 50       15 if(!defined($self->{logger})) {
107 4 50       33 Log::Log4perl->easy_init($self->{verbose} ? $Log::Log4perl::DEBUG : $Log::Log4perl::ERROR);
108 4         12227 $self->{logger} = Log::Log4perl->get_logger();
109             }
110              
111             # Return the blessed object
112 4         752 return bless $self, $class;
113             }
114              
115             =head2 analyze(@modules)
116              
117             Analyzes the provided modules. Returns an array reference of unsupported modules.
118              
119             =cut
120              
121             sub analyze {
122 0     0 1   my ($self, @modules) = @_;
123 0 0         croak('No modules provided for analysis') unless(@modules);
124              
125 0           my @results;
126 0           for my $module (@modules) {
127 0           $self->{logger}->debug("Analyzing module $module");
128              
129 0           my $test_data = $self->_fetch_testers_data($module);
130 0           my $release_data = $self->_fetch_release_data($module);
131              
132 0           my $unsupported = $self->_evaluate_support($module, $test_data, $release_data);
133 0 0         push @results, $unsupported if($unsupported);
134             }
135              
136 0           return \@results;
137             }
138              
139             =head2 output_results
140              
141             $report = $object->output_results($results, $format);
142              
143             Generates a report in the specified format.
144              
145             =over 4
146              
147             =item * C<$results> (ArrayRef)
148              
149             An array reference containing hashrefs with information about modules (module name, failure rate, last update)
150             as created by the analyze() method.
151              
152             =item * C<$format> (String)
153              
154             A string indicating the desired format for the report. Can be one of the following:
155              
156             =over 4
157              
158             =item C<text> (default)
159              
160             Generates a plain text report.
161              
162             =item C<html>
163              
164             Generates an HTML report.
165              
166             =item C<json>
167              
168             Generates a JSON report.
169              
170             =back
171              
172             =back
173              
174             =cut
175              
176             sub output_results {
177 0     0 1   my ($self, $results, $format) = @_;
178 0   0       $format ||= 'text'; # Default to plain text
179              
180 0 0         if($format eq 'json') {
    0          
181 0           return encode_json($results);
182             } elsif($format eq 'html') {
183 0           return $self->_generate_html_report($results);
184             } else {
185 0           return $self->_generate_text_report($results);
186             }
187             }
188              
189             sub _generate_text_report {
190 0     0     my ($self, $results) = @_;
191 0           my $report = '';
192              
193 0           for my $module (@{$results}) {
  0            
194 0           $report .= "Module: $module->{module}\n";
195 0           $report .= "\tFailure Rate: $module->{failure_rate}\n";
196 0           $report .= "\tLast Update: $module->{last_update}\n";
197 0           $report .= "\tHas Recent Tests: $module->{recent_tests}\n";
198 0           $report .= "\tReverse Dependencies: $module->{reverse_deps}\n";
199 0           $report .= "\tHas Unsupported Dependencies: $module->{has_unsupported_deps}\n";
200             }
201              
202 0           return $report;
203             }
204              
205             sub _generate_html_report {
206 0     0     my ($self, $results) = @_;
207              
208 0           my $html = '<html><head><title>Unsupported Modules Report</title></head><body><h1>Unsupported Modules Report</h1><ul>';
209              
210 0           for my $module (@{$results}) {
  0            
211 0           $html .= "<li><strong>$module->{module}</strong>:<br>";
212 0           $html .= "Failure Rate: $module->{failure_rate}<br>";
213 0           $html .= "Last Update: $module->{last_update}<br>";
214 0           $html .= "Has Recent Tests: $module->{recent_tests}<br>";
215 0           $html .= "Reverse Dependencies: $module->{reverse_deps}<br>";
216 0           $html .= "Has Unsupported Dependencies: $module->{has_unsupported_deps}<br></li>";
217             }
218              
219 0           $html .= '</ul></body></html>';
220 0           return $html;
221             }
222              
223             sub _fetch_testers_data {
224 0     0     my ($self, $module) = @_;
225              
226 0           my $url = "$self->{cpan_testers}/summary/$module";
227 0           return $self->_fetch_data($url);
228             }
229              
230             sub _fetch_release_data {
231 0     0     my ($self, $module) = @_;
232              
233 0           my $url = "$self->{api_url}/release/_search?q=distribution:$module&size=1&sort=date:desc";
234 0           return $self->_fetch_data($url);
235             }
236              
237             sub _fetch_data {
238 0     0     my ($self, $url) = @_;
239              
240 0           $self->{logger}->debug("Fetching data from $url");
241              
242 0           my $response = HTTP::Tiny->new()->get($url);
243              
244 0 0         if($response->{success}) {
245 0           $self->{logger}->debug("Data fetched successfully from $url");
246 0           return eval { decode_json($response->{content}) };
  0            
247             }
248 0           $self->{logger}->debug("Status = $response->{status}");
249 0 0 0       if(($response->{'status'} != 200) && ($url =~ /::/)) {
250             # Some modules use hyphens as delineators
251 0           $url =~ s/::/-/g;
252 0           return $self->_fetch_data($url);
253             }
254 0           $self->{logger}->error("Failed to fetch data from $url: $response->{status}");
255 0           return;
256             }
257              
258             sub _fetch_reverse_dependencies {
259 0     0     my ($self, $module) = @_;
260              
261 0           my $url = "$self->{api_url}/reverse_dependencies/$module";
262              
263 0           return $self->_fetch_data($url);
264             }
265              
266             # Evaluate the support status of a module.
267              
268             # Evaluates the module's failure rate, last update date, test history, and dependencies.
269              
270             # $module: The name of the module being evaluated.
271             # $test_data: Test results data for the module.
272             # $release_data: Release metadata for the module.
273              
274             # Returns a hashref containing the module's evaluation details if it's flagged as unsupported,
275             # undef if the module is considered supported.
276              
277             sub _evaluate_support {
278 0     0     my ($self, $module, $test_data, $release_data) = @_;
279              
280 0           my $failure_rate = $self->_calculate_failure_rate($test_data);
281 0   0       my $last_update = $self->_get_last_release_date($release_data) || 'Unknown';
282              
283             # Reverse Dependencies: Modules with many reverse dependencies have higher priority for support.
284 0           my $reverse_deps = $self->_fetch_reverse_dependencies($module);
285              
286             # Check if there are any test results in the last 6 months
287 0           my $has_recent_tests = $self->_has_recent_tests($test_data);
288              
289             # Check if the module has dependencies marked as deprecated or unsupported
290 0           my $has_unsupported_dependencies = $self->_has_unsupported_dependencies($module);
291              
292             # Check if the module is unsupported based on the criteria
293             # Flag module as unsupported if:
294             # - High failure rate (> 50%)
295             # - No recent updates
296             # - No recent test results in the last 6 months
297             # - Has unsupported dependencies
298 0 0 0       if(($failure_rate > 0.5) || ($last_update eq 'Unknown') || ($last_update lt '2022-01-01') || !$has_recent_tests || $has_unsupported_dependencies) {
      0        
      0        
      0        
299             return {
300             module => $module,
301             failure_rate => $failure_rate,
302             last_update => $last_update,
303             recent_tests => $has_recent_tests ? 'Yes' : 'No',
304 0 0 0       reverse_deps => $reverse_deps->{total} || 0,
    0          
305             has_unsupported_deps => $has_unsupported_dependencies ? 'Yes' : 'No',
306             };
307             }
308              
309 0           return; # Module is considered supported
310             }
311              
312             # Helper function to calculate the date six months ago
313             sub _six_months_ago {
314 0     0     my @time = localtime(time - 6 * 30 * 24 * 60 * 60); # Approximate six months in seconds
315 0           return sprintf "%04d-%02d-%02d", $time[5] + 1900, $time[4] + 1, $time[3];
316             }
317              
318             sub _has_recent_tests
319             {
320             # FIXME
321 0     0     return 1; # The API is currently unavailable
322              
323 0           my ($self, $test_data) = @_;
324              
325             # Assume $test_data contains test reports with a timestamp field
326 0           my $six_months_ago = $self->_six_months_ago();
327              
328 0           foreach my $test(@{$test_data}) {
  0            
329 0           ::diag(__LINE__);
330 0           ::diag($test->{timestamp});
331 0           ::diag($six_months_ago);
332 0 0 0       if($test->{timestamp} && ($test->{timestamp} > $six_months_ago)) {
333 0           return 1; # Recent test found
334             }
335             }
336              
337 0           return 0; # No recent tests found
338             }
339              
340              
341             # The API is currently unavailable
342             sub _calculate_failure_rate {
343 0     0     my ($self, $test_data) = @_;
344              
345 0 0 0       return 0 unless $test_data && $test_data->{results};
346              
347 0           my $total_tests = $test_data->{results}{total};
348 0           my $failures = $test_data->{results}{fail};
349              
350 0 0         return $total_tests ? $failures / $total_tests : 1;
351             }
352              
353             sub _get_last_release_date {
354 0     0     my ($self, $release_data) = @_;
355 0 0 0       return unless $release_data && $release_data->{hits}{hits}[0];
356              
357 0           return $release_data->{hits}{hits}[0]{_source}{date};
358             }
359              
360             sub _has_unsupported_dependencies {
361 0     0     my ($self, $module) = @_;
362              
363 0           my $url = "$self->{api_url}/release/$module";
364              
365 0           my $release_data = $self->_fetch_data($url);
366 0 0         if(!$release_data) {
367 0           $self->{'logger'}->warn("Failed to parse MetaCPAN response for $module");
368 0           return 0;
369             }
370              
371             # Extract dependencies
372 0   0       my $dependencies = $release_data->{dependency} || [];
373 0           foreach my $dependency (@$dependencies) {
374             # Skip if the dependency is marked as optional
375 0 0 0       next if $dependency->{phase} && $dependency->{phase} eq 'develop';
376              
377 0           my $dep_module = $dependency->{module};
378 0           my $dep_status = $self->_check_module_status($dep_module);
379              
380 0 0 0       if ($dep_status->{deprecated} || $dep_status->{backpan_only}) {
381 0           return 1; # Found an unsupported dependency
382             }
383             }
384              
385 0           return 0; # No unsupported dependencies found
386             }
387              
388             sub _check_module_status {
389 0     0     my ($self, $module) = @_;
390              
391 0           my $url = "$self->{api_url}/module/$module";
392              
393 0           my $module_data = $self->_fetch_data($url);
394             # my $module_data = eval { decode_json($response->{content}) };
395 0 0         if (!$module_data) {
396 0           $self->{'logger'}->warn("Failed to parse MetaCPAN response for $module");
397 0           return {};
398             }
399              
400             return {
401             deprecated => $module_data->{status} && $module_data->{status} eq 'deprecated',
402 0   0       backpan_only => $module_data->{maturity} && $module_data->{maturity} eq 'backpan',
      0        
403             };
404             }
405              
406             1;
407              
408             __END__
409              
410             =head1 AUTHOR
411              
412             Nigel Horne <njh@bandsman.co.uk>
413              
414             =head1 BUGS
415              
416             The cpantesters API, L<https://api.cpantesters.org/>, is currently unavailable,
417             so the routine _has_recent_tests() currently always returns 1.
418              
419             =head1 LICENCE
420              
421             This program is released under the following licence: GPL2