view release on metacpan or  search on metacpan

lib/CPAN/Audit.pm  view on Meta::CPAN

package CPAN::Audit;
use v5.10.1;
use strict;
use warnings;
use version;

use Carp qw(carp);
use Module::CoreList;

use CPAN::Audit::Installed;
use CPAN::Audit::Discover;
use CPAN::Audit::Filter;
use CPAN::Audit::Version;
use CPAN::Audit::Query;
use CPANSA::DB;

our $VERSION = '20260308.002';

sub new {
	my( $class, %params ) = @_;

	my @allowed_keys = qw(ascii db exclude exclude_file include_perl interactive no_corelist quiet verbose version);

	my %args = map { $_, $params{$_} } @allowed_keys;
	my $self = bless \%args, $class;

	$self->_handle_exclude_file if $self->{exclude_file};

	$self->{db} //= $self->_get_db(%args);

	$self->{filter}   = CPAN::Audit::Filter->new( exclude => $args{exclude} );
	$self->{query}    = CPAN::Audit::Query->new( db => $self->{db} );
	$self->{discover} = CPAN::Audit::Discover->new( db => $self->{db} );

	return $self;
}

sub _get_db {
	my( $self, %params ) = @_;

	if ( $params{'json_db'} ) {
		my $data = do {
			local $/;
			open my($fh), '<:raw', $params{'json_db'}
				or die "could not read file <$params{json_db}>\n";
			<$fh>;
		};
		state $rc = require JSON;

		my $decoded = eval { JSON::decode_json($data) };
		die "could not decode JSON from <$params{json_db}>: @_\n" unless defined $decoded;
		return $decoded;
	}

	my $rc = eval { require CPANSA::DB };
	if ( $rc ) {
		return CPANSA::DB->db;
	}

	$rc = eval {
		warn "CPAN::Audit::DB is deprecated. Use CPANSA::DB instead.\n";
		require CPAN::Audit::DB
		};
	if ( $rc ) {
		return CPAN::Audit::DB->db;
	}

	die "could not find a CPANSA database in CPANSA::DB or CPAN::Audit::DB\n";
}

sub _handle_exclude_file {
	my( $self ) = @_;

	foreach my $file (@{$self->{exclude_file}}) {
		my $fh;
		unless( open $fh, "<", $file ) {
			carp "unable to open exclude_file [$file]: $!\n";
			return;
		}
		my @excludes =
			grep { !/^\s*$/ }               # no blank lines
			map  { s{^\s+|\s+$}{}g; $_ }    # strip leading/trailing whitespace
			map  { s{#.*}{}; $_ }           # strip comments
			<$fh>;
		push @{$self->{exclude}}, @excludes;
		}
}

sub command_module {
	my ( $self, $dists, $queried, $module, $version_range ) = @_;
	return "Usage: module <module> [version-range]" unless $module;

	my $distname = $self->{db}->{module2dist}->{$module};

	if ( !$distname ) {
		return "Module '$module' is not in database";
	}

	push @{ $queried->{$distname} }, $module;
	$dists->{$distname} = $version_range // '';

	return;
}

sub command_release {
	my ( $self, $dists, $queried, $distname, $version_range ) = @_;
	return "Usage: dist|release <module> [version-range]"
		unless $distname;