307 lines
7.6 KiB
Perl
307 lines
7.6 KiB
Perl
package CPAN::Audit;
|
|
use 5.008001;
|
|
use strict;
|
|
use warnings;
|
|
use version;
|
|
use CPAN::Audit::Installed;
|
|
use CPAN::Audit::Discover;
|
|
use CPAN::Audit::Version;
|
|
use CPAN::Audit::Query;
|
|
use CPAN::Audit::DB;
|
|
use Module::CoreList;
|
|
|
|
our $VERSION = "0.15";
|
|
|
|
sub new {
|
|
my $class = shift;
|
|
my (%params) = @_;
|
|
|
|
my $self = {};
|
|
bless $self, $class;
|
|
|
|
$self->{ascii} = $params{ascii};
|
|
$self->{verbose} = $params{verbose};
|
|
$self->{quiet} = $params{quiet};
|
|
$self->{no_color} = $params{no_color};
|
|
$self->{no_corelist} = $params{no_corelist};
|
|
$self->{interactive} = $params{interactive};
|
|
|
|
if ( !$self->{interactive} ) {
|
|
$self->{ascii} = 1;
|
|
$self->{no_color} = 1;
|
|
}
|
|
|
|
$self->{db} = CPAN::Audit::DB->db;
|
|
$self->{query} = CPAN::Audit::Query->new( db => $self->{db} );
|
|
$self->{discover} = CPAN::Audit::Discover->new( db => $self->{db} );
|
|
|
|
return $self;
|
|
}
|
|
|
|
sub command {
|
|
my $self = shift;
|
|
my ( $command, @args ) = @_;
|
|
|
|
my %dists;
|
|
|
|
if (!$self->{no_corelist}
|
|
&& ( $command eq 'dependencies'
|
|
|| $command eq 'deps'
|
|
|| $command eq 'installed' )
|
|
)
|
|
{
|
|
# Find core modules for this perl version first.
|
|
# This way explictly installed versions will overwrite.
|
|
if ( my $core = $Module::CoreList::version{$]} ) {
|
|
while ( my ( $mod, $ver ) = each %$core ) {
|
|
my $dist = $self->{db}{module2dist}{$mod} or next;
|
|
|
|
$dists{$dist} = $ver if version->parse($ver) > $dists{$dist};
|
|
}
|
|
}
|
|
}
|
|
|
|
if ( $command eq 'module' ) {
|
|
my ( $module, $version_range ) = @args;
|
|
$self->fatal("Usage: module <module> [version-range]") unless $module;
|
|
|
|
my $distname = $self->{db}->{module2dist}->{$module};
|
|
|
|
if ( !$distname ) {
|
|
$self->message("__GREEN__Module '$module' is not in database");
|
|
return 0;
|
|
}
|
|
|
|
$dists{$distname} = $version_range || '';
|
|
}
|
|
elsif ( $command eq 'release' || $command eq 'dist' ) {
|
|
my ( $distname, $version_range ) = @args;
|
|
$self->fatal("Usage: dist|release <module> [version-range]")
|
|
unless $distname;
|
|
|
|
if ( !$self->{db}->{dists}->{$distname} ) {
|
|
$self->message("__GREEN__Distribution '$distname' is not in database");
|
|
return 0;
|
|
}
|
|
|
|
$dists{$distname} = $version_range || '';
|
|
}
|
|
elsif ( $command eq 'show' ) {
|
|
my ($advisory_id) = @args;
|
|
$self->fatal("Usage: show <advisory-id>") unless $advisory_id;
|
|
|
|
my ($release) = $advisory_id =~ m/^CPANSA-(.*?)-(\d+)-(\d+)$/;
|
|
$self->fatal("Invalid advisory id") unless $release;
|
|
|
|
my $dist = $self->{db}->{dists}->{$release};
|
|
$self->fatal("Unknown advisory id") unless $dist;
|
|
|
|
my ($advisory) =
|
|
grep { $_->{id} eq $advisory_id } @{ $dist->{advisories} };
|
|
$self->fatal("Unknown advisory id") unless $advisory;
|
|
|
|
$self->print_advisory($advisory);
|
|
|
|
return 0;
|
|
}
|
|
elsif ( $command eq 'dependencies' || $command eq 'deps' ) {
|
|
my ($path) = @args;
|
|
$path = '.' unless defined $path;
|
|
|
|
$self->fatal("Usage: deps <path>") unless -d $path;
|
|
|
|
my @deps = $self->{discover}->discover($path);
|
|
|
|
$self->message( 'Discovered %d dependencies', scalar(@deps) );
|
|
|
|
foreach my $dep (@deps) {
|
|
my $dist = $dep->{dist}
|
|
|| $self->{db}->{module2dist}->{ $dep->{module} };
|
|
next unless $dist;
|
|
|
|
$dists{$dist} = $dep->{version};
|
|
}
|
|
}
|
|
elsif ( $command eq 'installed' ) {
|
|
$self->message_info('Collecting all installed modules. This can take a while...');
|
|
|
|
my @deps = CPAN::Audit::Installed->new(
|
|
db => $self->{db},
|
|
$self->{verbose}
|
|
? (
|
|
cb => sub {
|
|
my ($info) = @_;
|
|
|
|
$self->message( '%s: %s-%s', $info->{path}, $info->{distname}, $info->{version} );
|
|
}
|
|
)
|
|
: ()
|
|
)->find(@ARGV);
|
|
|
|
foreach my $dep (@deps) {
|
|
my $dist = $dep->{dist}
|
|
|| $self->{db}->{module2dist}->{ $dep->{module} };
|
|
next unless $dist;
|
|
|
|
$dists{ $dep->{dist} } = $dep->{version};
|
|
}
|
|
}
|
|
else {
|
|
$self->fatal("Error: unknown command: $command. See -h");
|
|
}
|
|
|
|
my $total_advisories = 0;
|
|
|
|
if (%dists) {
|
|
my $query = $self->{query};
|
|
|
|
foreach my $distname ( sort keys %dists ) {
|
|
my $version_range = $dists{$distname};
|
|
|
|
my @advisories = $query->advisories_for( $distname, $version_range );
|
|
|
|
$version_range = 'Any'
|
|
if $version_range eq '' || $version_range eq '0';
|
|
|
|
if (@advisories) {
|
|
$self->message( '__RED__%s (requires %s) has %d advisories__RESET__',
|
|
$distname, $version_range, scalar(@advisories) );
|
|
|
|
foreach my $advisory (@advisories) {
|
|
$self->print_advisory($advisory);
|
|
}
|
|
}
|
|
|
|
$total_advisories += @advisories;
|
|
}
|
|
}
|
|
|
|
if ($total_advisories) {
|
|
$self->message( '__RED__Total advisories found: %d__RESET__', $total_advisories );
|
|
|
|
return $total_advisories;
|
|
}
|
|
else {
|
|
$self->message_info('__GREEN__No advisories found__RESET__');
|
|
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
sub message_info {
|
|
my $self = shift;
|
|
|
|
return if $self->{quiet};
|
|
|
|
$self->message(@_);
|
|
}
|
|
|
|
sub message {
|
|
my $self = shift;
|
|
|
|
$self->_print( *STDOUT, @_ );
|
|
}
|
|
|
|
sub fatal {
|
|
my $self = shift;
|
|
my ( $msg, @args ) = @_;
|
|
|
|
$self->_print( *STDERR, "Error: $msg", @args );
|
|
exit 255;
|
|
}
|
|
|
|
sub print_advisory {
|
|
my $self = shift;
|
|
my ($advisory) = @_;
|
|
|
|
$self->message(" __BOLD__* $advisory->{id}");
|
|
|
|
print " $advisory->{description}\n";
|
|
|
|
if ( $advisory->{affected_versions} ) {
|
|
print " Affected range: $advisory->{affected_versions}\n";
|
|
}
|
|
|
|
if ( $advisory->{fixed_versions} ) {
|
|
print " Fixed range: $advisory->{fixed_versions}\n";
|
|
}
|
|
|
|
if ( $advisory->{cves} ) {
|
|
print "\n CVEs: ";
|
|
print join ', ', @{ $advisory->{cves} };
|
|
print "\n";
|
|
}
|
|
|
|
if ( $advisory->{references} ) {
|
|
print "\n References:\n";
|
|
foreach my $reference ( @{ $advisory->{references} || [] } ) {
|
|
print " $reference\n";
|
|
}
|
|
}
|
|
|
|
print "\n";
|
|
}
|
|
|
|
sub _print {
|
|
my $self = shift;
|
|
my ( $fh, $format, @params ) = @_;
|
|
|
|
my $msg = @params ? ( sprintf( $format, @params ) ) : ($format);
|
|
|
|
if ( $self->{no_color} ) {
|
|
$msg =~ s{__BOLD__}{}g;
|
|
$msg =~ s{__GREEN__}{}g;
|
|
$msg =~ s{__RED__}{}g;
|
|
$msg =~ s{__RESET__}{}g;
|
|
}
|
|
else {
|
|
$msg =~ s{__BOLD__}{\e[39;1m}g;
|
|
$msg =~ s{__GREEN__}{\e[32m}g;
|
|
$msg =~ s{__RED__}{\e[31m}g;
|
|
$msg =~ s{__RESET__}{\e[0m}g;
|
|
|
|
$msg .= "\e[0m";
|
|
}
|
|
|
|
print $fh "$msg\n";
|
|
}
|
|
|
|
1;
|
|
__END__
|
|
|
|
=encoding utf-8
|
|
|
|
=head1 NAME
|
|
|
|
CPAN::Audit - Audit CPAN distributions for known vulnerabilities
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use CPAN::Audit;
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
CPAN::Audit is a module and a database at the same time. It is used by L<cpan-audit> command line application to query
|
|
for vulnerabilities.
|
|
|
|
=head1 LICENSE
|
|
|
|
Copyright (C) Viacheslav Tykhanovskyi.
|
|
|
|
This library is free software; you can redistribute it and/or modify
|
|
it under the same terms as Perl itself.
|
|
|
|
=head1 AUTHOR
|
|
|
|
Viacheslav Tykhanovskyi E<lt>viacheslav.t@gmail.comE<gt>
|
|
|
|
=head1 CREDITS
|
|
|
|
Takumi Akiyama (github.com/akiym)
|
|
|
|
James Raspass (github.com/JRaspass)
|
|
|
|
MCRayRay (github.com/MCRayRay)
|
|
|
|
=cut
|