script/cpan-license-check

Rama main · réplica de lectura del repositorio original.

#!/usr/bin/env perl
# SPDX-FileCopyrightText: 2026 GPForum Contributors
# SPDX-License-Identifier: BSD-3-Clause

package main;

use v5.40;

use Carp    qw(croak);
use English qw(-no_match_vars);

our $VERSION = '0.001';

my $review_file = 'docs/CPAN_LICENSE_REVIEW.md';
my @cpanfiles   = qw(cpanfile cpanfile.postgres);

my $review       = _slurp($review_file);
my @dependencies = _dependencies(@cpanfiles);
my %rows         = _review_rows($review);

# Zero dependencies is a parse failure, not a clean bill: the manifest this
# reads declares dozens. Reporting status=ok reviewed=0 would pass a gate that
# looked at nothing.
if ( !@dependencies ) {
    warn 'cpan-license-check status=fail reason=no-dependencies-read' . "\n";
    exit 1;
}

my @missing;
my @blocked;

for my $dependency (@dependencies) {
    if ( !exists $rows{$dependency} ) {
        push @missing, $dependency;
        next;
    }

    my $decision = $rows{$dependency}{decision};
    if ( $decision ne 'allowed' && $decision ne 'dev-only allowed' ) {
        push @blocked, $dependency . q{:} . $decision;
    }
}

if ( @missing || @blocked ) {
    print 'cpan-license-check status=fail'
      . ' missing='
      . join( q{,}, @missing )
      . ' blocked='
      . join( q{,}, @blocked ) . "\n"
      or croak 'failed to write CPAN license result';
    exit 1;
}

print 'cpan-license-check status=ok reviewed=' . scalar(@dependencies) . "\n"
  or croak 'failed to write CPAN license result';

exit 0;

sub _dependencies {
    my (@files) = @_;

    my @declared;

    for my $file (@files) {
        next if !-f $file;

        my $content = _slurp($file);
        while ( $content =~ /^[ \t]* requires [ \t]+ '([^']+)'/gmsx ) {
            push @declared, $1;
        }
    }

    return @declared;
}

sub _review_rows {
    my ($content) = @_;

    my %row_for;
    for my $line ( split /\n/msx, $content ) {
        next if $line !~ /\A [|]/msx;
        next if $line =~ /\A [|] [ ]* Module [ ]* [|]/msx;
        next if $line =~ /\A [|] [-: ]+ [|]/msx;

        # The text before the first bar, then the row's five columns; a row
        # without a decision is not a review row.
        my ( undef, $module, $scope, $license, $risk, $decision ) =
          map { _trim($_) } split /[|]/msx, $line;
        next if !defined $decision;
        next if !defined $module || !length $module;

        $row_for{$module} = {
            scope    => $scope,
            license  => $license,
            risk     => $risk,
            decision => $decision,
        };
    }

    return %row_for;
}

sub _slurp {
    my ($file) = @_;

    open my $handle, '<', $file
      or croak "failed to read $file";

    local $INPUT_RECORD_SEPARATOR = undef;
    my $content = <$handle>;

    close $handle
      or croak "failed to close $file";

    return $content;
}

sub _trim {
    my ($value) = @_;

    $value =~ s/\A \s+//msx;
    $value =~ s/\s+ \z//msx;

    return $value;
}