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;

# Stricter than CPAN::Audit::FreshnessCheck's own default of 30 days, deliberately.
# Upstream's threshold serves an interactive audit, where a warning on STDERR is
# read by the person who typed the command. This is a release gate, and 30 days is
# precisely the age at which this project's database silently lacked the URI
# advisory that a clean verdict was then cited to disprove (DD-790). The knob is
# upstream's own CPAN_AUDIT_FRESH_DAYS, so one name moves the warning and the
# refusal together rather than letting two thresholds disagree in silence.
#
# WHY 21 AND NOT A ROUNDER NUMBER. The limit must EXCEED THE LARGEST REAL GAP
# BETWEEN PUBLICATIONS, or the gate refuses during a normal quiet spell while no
# newer database exists to install - blocking for a reason nobody can act on, which
# is how a gate gets routed around instead of fixed. Measured from the CPAN index
# on 2026-09-06 across 40 CPANSA-DB releases spanning 223 days: median gap 4 days,
# mean 5.7, MAXIMUM 18, with 1 gap of 39 exceeding 14 days and none exceeding 30.
# 21 clears the observed maximum with three days of margin and still catches the
# 30-day staleness this card was raised for. IF A LONGER GAP EVER APPEARS UPSTREAM,
# THIS IS THE NUMBER THAT MOVES - the measurement, not the constant, is the reason.
# And 18 is the maximum of a 223-DAY WINDOW, which is one sample of the tail rather
# than the tail itself: read 21 as "chosen against the largest gap seen in 223 days",
# never as a proven ceiling.
use constant DEFAULT_MAX_DB_AGE_DAYS => 21;

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;

    # The corpus is established BEFORE the subject is walked, because a database
    # too old to answer with makes every later step moot - and reporting it only
    # on the failure path would name the database exactly when nobody needs it.
    my $corpus = _corpus_report($perl5_root);
    # Flushed, because the refusal below goes to STDERR while this goes to STDOUT.
    # Block-buffered, the corpus line lands AFTER the refusal in any combined log -
    # so the reader meets "refused because the database is old" before being told
    # which database, which is the wrong way round for the only line that explains it.
    local $| = 1;
    print $corpus->{line};
    return _unusable( $corpus->{refusal} ) if defined $corpus->{refusal};

    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} );