view release on metacpan or  search on metacpan

script/cpan-audit-declared-chain  view on Meta::CPAN

#!/usr/bin/env perl

# IMPORTANT: this gate answers a different question from script/cpan-audit-project.
# That gate asks "is the set of distributions installed in this root vulnerable?".
# This gate asks "does the declared dependency chain PERMIT a vulnerable
# resolution?" - which is what an installer actually decides. A resolver always
# takes the newest release, so an installed-only audit stays green even while
# the declared floors allow a vulnerable version, and a floor list derived from
# the modules cpanfile names never sees the transitive requirements that
# libwww-perl, Dancer2 and JSON::MaybeXS pull in on their own.

use strict;
use warnings;

use File::Basename qw(basename dirname);
use File::Spec;
use Getopt::Long qw(GetOptions);
use JSON::XS ();

use constant EXIT_CLEAN   => 0;
use constant EXIT_FINDING => 1;
use constant EXIT_UNUSABLE => 2;

exit main(@ARGV);

# Purpose: run the declared-chain advisory gate end to end.
# Input: the raw @ARGV list (one positional Perl library root, plus the
#        optional --cpanfile and --exclude-file overrides).
# Output: an exit code - 0 clean, 1 at least one permitted vulnerable
#         resolution, 2 the gate could not audit anything and refuses to
#         report a clean result it did not establish.
sub main {
    my @argv = @_;

    my $repo_root = File::Spec->rel2abs( File::Spec->catdir( dirname(__FILE__), File::Spec->updir ) );
    my $cpanfile  = File::Spec->catfile( $repo_root, 'cpanfile' );
    my $exclusions = File::Spec->catfile( $repo_root, 'cpan-audit-exclusions.txt' );

    local @ARGV = @argv;
    GetOptions(
        'cpanfile=s'     => \$cpanfile,
        'exclude-file=s' => \$exclusions,
    ) or return _usage('unrecognized option');
    my @positional = @ARGV;

    return _usage('exactly one Perl library root is required')
        if @positional != 1;
    my $perl5_root = $positional[0];
    return _usage("not a directory: $perl5_root") if !-d $perl5_root;
    return _usage("cpanfile not readable: $cpanfile") if !-f $cpanfile;

    my $version_class = _load_audit_modules();
    return _unusable('CPAN::Audit::DB and CPAN::Audit::Version must be loadable; install CPAN::Audit and put it on PERL5LIB')
        if !$version_class;

    my $declared = _parse_cpanfile($cpanfile);
    return _unusable("no runtime requirements declared in $cpanfile")
        if !%{$declared};

    my $metadata = _index_metadata($perl5_root);
    return _unusable(
        sprintf 'the closure would be incomplete - %d distribution metadata file(s) could not be read: %s',
        scalar @{ $metadata->{unusable} },
        join( '; ', @{ $metadata->{unusable} } )
    ) if @{ $metadata->{unusable} };
    return _unusable("no distribution metadata (.meta) found under $perl5_root; the declared chain cannot be walked")
        if !%{ $metadata->{module_to_dist} };

    my $demand = _closure( $declared, $metadata );
    my $floors = _distribution_floors( $demand, $metadata );
    my $excluded = _read_exclusions($exclusions);

    my @findings = _findings( $floors, $excluded, $version_class );

    printf "declared-chain closure: %d modules across %d distributions under %s\n",
        scalar( keys %{$demand} ), scalar( keys %{$floors} ), $perl5_root;

    if ( !@findings ) {
        print "No distribution in the declared runtime closure permits a version inside an advisory range.\n";
        return EXIT_CLEAN;
    }

    for my $finding ( @findings ) {
        printf "%s permits %s which has advisory %s\n",
            $finding->{distribution}, $finding->{permitted}, $finding->{advisory};
        printf "    affected range: %s\n", $finding->{affected};
        printf "    fixed range:    %s\n", ( $finding->{fixed} eq '' ? '(no fixed release)' : $finding->{fixed} );
        printf "    floor demanded: %s (%s)\n", $finding->{floor}, $finding->{because};
        printf "    remedy:         declare a floor for %s at or above the fixed range in cpanfile, Makefile.PL and dist.ini, or record a reviewed disposition for %s\n",
            $finding->{main_module}, $finding->{advisory};
    }
    printf "%d permitted vulnerable resolution(s) in the declared chain\n", scalar(@findings);

    return EXIT_FINDING;
}

# Purpose: print the usage diagnostic for a caller error.
# Input: a one-line reason string.
# Output: the EXIT_UNUSABLE exit code (the message goes to STDERR).