File Coverage

lib/CPAN/Audit.pm
Criterion Covered Total %
statement 35 166 21.0
branch 0 60 0.0
condition 0 28 0.0
subroutine 12 24 50.0
pod 0 9 0.0
total 47 287 16.3


line stmt bran cond sub pod time code
1             package CPAN::Audit;
2 2     2   3430 use v5.10.1;
  2         13  
3 2     2   10 use strict;
  2         6  
  2         43  
4 2     2   11 use warnings;
  2         8  
  2         54  
5 2     2   947 use version;
  2         3815  
  2         12  
6              
7 2     2   152 use Carp qw(carp);
  2         2  
  2         118  
8 2     2   8969 use Module::CoreList;
  2         285767  
  2         27  
9              
10 2     2   3437 use CPAN::Audit::Installed;
  2         5  
  2         75  
11 2     2   753 use CPAN::Audit::Discover;
  2         5  
  2         64  
12 2     2   748 use CPAN::Audit::Filter;
  2         6  
  2         65  
13 2     2   736 use CPAN::Audit::Version;
  2         4  
  2         69  
14 2     2   746 use CPAN::Audit::Query;
  2         4  
  2         68  
15 2     2   12 use CPAN::Audit::DB;
  2         3  
  2         3802  
16              
17             our $VERSION = '20230709.001';
18              
19             sub new {
20 0     0 0   my( $class, %params ) = @_;
21              
22 0           my @allowed_keys = qw(ascii db exclude exclude_file include_perl interactive no_corelist quiet verbose version);
23              
24 0           my %args = map { $_, $params{$_} } @allowed_keys;
  0            
25 0           my $self = bless \%args, $class;
26              
27 0 0         $self->_handle_exclude_file if $self->{exclude_file};
28              
29 0           $self->{db} = CPAN::Audit::DB->db;
30              
31 0           $self->{filter} = CPAN::Audit::Filter->new( exclude => $args{exclude} );
32 0           $self->{query} = CPAN::Audit::Query->new( db => $self->{db} );
33 0           $self->{discover} = CPAN::Audit::Discover->new( db => $self->{db} );
34              
35 0           return $self;
36             }
37              
38             sub _handle_exclude_file {
39 0     0     my( $self ) = @_;
40              
41 0           foreach my $file (@{$self->{exclude_file}}) {
  0            
42 0           my $fh;
43 0 0         unless( open $fh, "<", $file ) {
44 0           carp "unable to open exclude_file [$file]: $!\n";
45 0           return;
46             }
47             my @excludes =
48 0           grep { !/^\s*$/ } # no blank lines
49 0           map { s{^\s+|\s+$}{}g; $_ } # strip leading/trailing whitespace
  0            
50 0           map { s{#.*}{}; $_ } # strip comments
  0            
  0            
51             <$fh>;
52 0           push @{$self->{exclude}}, @excludes;
  0            
53             }
54             }
55              
56             sub command_module {
57 0     0 0   my ( $self, $dists, $queried, $module, $version_range ) = @_;
58 0 0         return "Usage: module [version-range]" unless $module;
59              
60 0           my $distname = $self->{db}->{module2dist}->{$module};
61              
62 0 0         if ( !$distname ) {
63 0           return "Module '$module' is not in database";
64             }
65              
66 0           push @{ $queried->{$distname} }, $module;
  0            
67 0   0       $dists->{$distname} = $version_range // '';
68              
69 0           return;
70             }
71              
72             sub command_release {
73 0     0 0   my ( $self, $dists, $queried, $distname, $version_range ) = @_;
74 0 0         return "Usage: dist|release [version-range]"
75             unless $distname;
76              
77 0 0         if ( !$self->{db}->{dists}->{$distname} ) {
78 0           return "Distribution '$distname' is not in database";
79             }
80              
81 0   0       $dists->{$distname} = $version_range // '';
82              
83 0           return;
84             }
85              
86             sub command_show {
87 0     0 0   my ( $self, $dists, $queried, $advisory_id ) = @_;
88 0 0         return "Usage: show " unless $advisory_id;
89              
90 0           my ($release) = $advisory_id =~ m/^CPANSA-(.*?)-(\d+)-(\d+)$/;
91 0 0         return "Invalid advisory id" unless $release;
92              
93 0           my $dist = $self->{db}->{dists}->{$release};
94 0 0         return "Unknown advisory id" unless $dist;
95              
96             my ($advisory) =
97 0           grep { $_->{id} eq $advisory_id } @{ $dist->{advisories} };
  0            
  0            
98 0 0         return "Unknown advisory id" unless $advisory;
99              
100 0   0       my $distname = $advisory->{distribution} // 'Unknown distribution name';
101 0           $dists->{$distname}{advisories} = [ $advisory ];
102 0           $dists->{$distname}{version} = 'Any';
103              
104 0           return;
105             }
106              
107             sub command_modules {
108 0     0 0   my ($self, $dists, $queried, @modules) = @_;
109 0 0         return "Usage: modules '[,version-range]' '[,version-range]'" unless @modules;
110              
111 0           foreach my $module ( @modules ) {
112 0           my ($name, $version) = split /;/, $module;
113              
114 0   0       my $failed = $self->command_module( $dists, $queried, $name, $version // '' );
115              
116 0 0         if ( $failed ) {
117 0           $self->verbose( $failed );
118 0           next;
119             }
120             }
121              
122 0           return;
123             }
124              
125             sub command_deps {
126 0     0 0   my ($self, $dists, $queried, $dir) = @_;
127 0 0         $dir = '.' unless defined $dir;
128              
129 0 0         return "Usage: deps " unless -d $dir;
130              
131 0           my @deps = $self->{discover}->discover($dir);
132              
133 0           $self->verbose( sprintf 'Discovered %d dependencies', scalar(@deps) );
134              
135 0           foreach my $dep (@deps) {
136             my $dist = $dep->{dist}
137 0   0       || $self->{db}->{module2dist}->{ $dep->{module} };
138 0 0         next unless $dist;
139              
140 0 0         push @{ $queried->{$dist} }, $dep->{module} if !$dep->{dist};
  0            
141              
142 0           $dists->{$dist} = $dep->{version};
143             }
144              
145 0           return;
146             }
147              
148             sub command_installed {
149 0     0 0   my ($self, $dists, $queried, @args) = @_;
150              
151 0           $self->verbose('Collecting all installed modules. This can take a while...');
152              
153             my $verbose_callback = sub {
154 0     0     my ($info) = @_;
155 0           $self->verbose( sprintf '%s: %s-%s', $info->{path}, $info->{distname}, $info->{version} );
156 0           };
157              
158             my @deps = CPAN::Audit::Installed->new(
159             db => $self->{db},
160             include_perl => $self->{include_perl},
161 0 0         ( $self->{verbose} ? ( cb => $verbose_callback ) : () ),
162             )->find(@args);
163              
164 0           foreach my $dep (@deps) {
165             my $dist = $dep->{dist}
166 0   0       || $self->{db}->{module2dist}->{ $dep->{module} };
167 0 0         next unless $dist;
168              
169 0           $dists->{ $dep->{dist} } = $dep->{version};
170             }
171              
172 0           return;
173             }
174              
175             sub command {
176 0     0 0   state $command_table = {
177             dependencies => 'command_deps',
178             deps => 'command_deps',
179             installed => 'command_installed',
180             module => 'command_module',
181             modules => 'command_modules',
182             release => 'command_release',
183             dist => 'command_release',
184             show => 'command_show',
185             };
186              
187 0           my( $self, $command, @args ) = @_;
188              
189 0           my %report = (
190             meta => {
191             command => $command,
192             args => [ @args ],
193             cpan_audit => { version => $VERSION },
194             total_advisories => 0,
195             },
196             errors => [],
197             dists => {},
198             );
199 0           my $dists = $report{dists};
200 0           my $queried = {};
201              
202 0 0 0       if (!$self->{no_corelist}
      0        
203             && ( $command eq 'dependencies'
204             || $command eq 'deps'
205             || $command eq 'installed' )
206             )
207             {
208             # Find core modules for this perl version first.
209             # This way explictly installed versions will overwrite.
210 0 0         if ( my $core = $Module::CoreList::version{$]} ) {
211 0           while ( my ( $mod, $ver ) = each %$core ) {
212 0 0         my $dist = $self->{db}{module2dist}{$mod} or next;
213 0 0 0       $dists->{$dist} = $ver if( ! defined $dists->{$dist} or version->parse($ver) > $dists->{$dist} );
214             }
215             }
216             }
217              
218 0 0         if ( exists $command_table->{$command} ) {
219 0           my $method = $command_table->{$command};
220 0           push @{ $report{errors} }, $self->$method( $dists, $queried, @args );
  0            
221 0 0         return \%report if $command eq 'show';
222             }
223             else {
224 0           push @{ $report{errors} }, "unknown command: $command. See -h";
  0            
225             }
226              
227 0 0         if (%$dists) {
228 0           my $query = $self->{query};
229              
230 0           foreach my $distname ( keys %$dists ) {
231 0           my $version_range = $dists->{$distname};
232             my @advisories =
233 0           grep { ! $self->{filter}->excludes($_) }
  0            
234             $query->advisories_for( $distname, $version_range );
235              
236 0 0 0       $version_range = 'Any'
237             if $version_range eq '' || $version_range eq '0';
238              
239 0           $report{meta}{total_advisories} += @advisories;
240              
241 0 0         if ( @advisories ) {
242             $dists->{$distname} = {
243             advisories => \@advisories,
244             version => $version_range,
245 0   0       queried_modules => $queried->{$distname} || [],
246             };
247             }
248             else {
249 0           delete $dists->{$distname}
250             }
251             }
252             }
253              
254 0           return \%report;
255             }
256              
257             sub verbose {
258 0     0 0   my ( $self, $message ) = @_;
259 0 0         return if $self->{quiet};
260 0           $self->_print( *STDERR, $message );
261             }
262              
263              
264             sub _print {
265 0     0     my ( $self, $fh, $message ) = @_;
266              
267 0 0         if ( $self->{no_color} ) {
268 0           $message =~ s{__BOLD__}{}g;
269 0           $message =~ s{__GREEN__}{}g;
270 0           $message =~ s{__RED__}{}g;
271 0           $message =~ s{__RESET__}{}g;
272             }
273             else {
274 0           $message =~ s{__BOLD__}{\e[39;1m}g;
275 0           $message =~ s{__GREEN__}{\e[32m}g;
276 0           $message =~ s{__RED__}{\e[31m}g;
277 0           $message =~ s{__RESET__}{\e[0m}g;
278              
279 0 0         $message .= "\e[0m" if length $message;
280             }
281              
282 0           print $fh "$message\n";
283             }
284              
285             1;
286             __END__