CPANPLUS-Dist-Debora/lib/CPANPLUS/Dist/Debora/Package.pm
package CPANPLUS::Dist::Debora::Package;
# SPDX-License-Identifier: Artistic-1.0-Perl OR GPL-1.0-or-later
use 5.016;
use warnings;
use utf8;
our $VERSION = '0.018';
use Carp qw(croak);
use Config;
use CPAN::Meta;
use English qw(-no_match_vars);
use File::Basename qw(dirname);
use File::Path qw(remove_tree);
use File::Spec::Functions qw(catdir catfile splitdir splitpath);
use File::Temp qw(tempdir);
use Net::Domain qw(hostfqdn);
use Software::LicenseUtils 0.103014;
use CPANPLUS::Dist::Debora::License;
use CPANPLUS::Dist::Debora::Pod;
use CPANPLUS::Dist::Debora::Util qw(
parse_version
module_is_distributed_with_perl
decode_utf8
can_run
run
find_most_recent_mtime
find_shared_objects
);
# Map some distribution names to special package names.
my %PACKAGE_NAME_FOR = (
'ack' => 'ack',
'App-Licensecheck' => 'licensecheck',
'App-perlbrew' => 'perlbrew',
'TermReadKey' => 'perl-Term-ReadKey',
);
# Version quirks.
my %VERSION_FOR = ('BioPerl-Run' => sub { parse_version($_[0])->normal });
# Modules with summaries and descriptions.
my %POD_FOR = (
'ack' => 'ack',
'App-Licensecheck' => 'licensecheck',
'TermReadKey' => 'ReadKey.pm.PL',
'TimeDate' => 'Date::Parse',
'YAML-LibYAML' => 'YAML::XS',
);
# Common modules whose license might not be guessed.
my %LICENSE_FOR = (
'AnyEvent' => 'Artistic-1.0-Perl OR GPL-1.0-or-later',
'Apache-Htpasswd' => 'Artistic-1.0-Perl OR GPL-1.0-or-later',
'Cache-Cache' => 'Artistic-1.0-Perl OR GPL-1.0-or-later',
'Canary-Stability' => 'Artistic-1.0-Perl OR GPL-1.0-or-later',
'CGI-FormBuilder' => 'Artistic-1.0-Perl OR GPL-1.0-or-later',
'CGI-FormBuilder-Source-Perl' => 'Artistic-1.0-Perl OR GPL-1.0-or-later',
'Crypt-CBC' => 'Artistic-1.0-Perl OR GPL-1.0-or-later',
'Encode-Detect' => 'MPL-1.1',
'Guard' => 'Artistic-1.0-Perl OR GPL-1.0-or-later',
'Iterator' => 'Artistic-1.0-Perl OR GPL-1.0-or-later',
'Iterator-Util' => 'Artistic-1.0-Perl OR GPL-1.0-or-later',
'Lingua-EN-Words2Nums' => 'Artistic-1.0-Perl OR GPL-1.0-or-later',
'Lingua-Stem-Snowball-Da' => 'GPL-2.0-only',
'Mozilla-CA' => 'MPL-2.0',
'Socket6' => 'BSD',
'String-ShellQuote' => 'Artistic-1.0-Perl OR GPL-1.0-or-later',
'Sub-Delete' => 'Artistic-1.0-Perl OR GPL-1.0-or-later',
'XML-Writer' => 'CC0-1.0',
);
sub new {
my ($class, %attrs) = @_;
my $attrs = $class->_buildargs(%attrs);
return bless $attrs, $class;
}
sub _buildargs {
my ($class, %attrs) = @_;
if (!exists $attrs{module}) {
croak 'No module';
}
my $builddir = $attrs{builddir} = $attrs{module}->status->extract;
if (!defined $builddir) {
croak 'No builddir';
}
if (!exists $attrs{installdirs}) {
$attrs{installdirs} = 'vendor';
}
my $installdirs = $attrs{installdirs};
if ($installdirs ne 'vendor' && $installdirs ne 'site') {
croak "installdirs is neither 'vendor' nor 'site': '$installdirs'";
}
if (!exists $attrs{build_number}) {
$attrs{build_number} = 1;
}
my $build_number = $attrs{build_number};
if ($build_number !~ m{\A [1-9]\d* \z}xms) {
croak "build_number is not a positive integer: '$build_number'";
}
$attrs{last_modification} = find_most_recent_mtime($builddir);
return \%attrs;
}
sub _read {
my ($self, $name, $default) = @_;
if (!exists $self->{$name}) {
$self->{$name} = $default->();
}
return $self->{$name};
}
sub module {
my $self = shift;
return $self->{module};
}
sub installdirs {
my $self = shift;
return $self->{installdirs};
}
sub sourcefile {
my $self = shift;
my $sourcefile
= $self->_read('sourcefile', sub { $self->module->status->fetch });
return $sourcefile;
}
sub sourcedir {
my $self = shift;
my $sourcedir
= $self->_read('sourcedir', sub { dirname($self->sourcefile) });
return $sourcedir;
}
sub last_modification {
my $self = shift;
return $self->{last_modification};
}
sub builddir {
my $self = shift;
return $self->{builddir};
}
sub outputdir {
my $self = shift;
my $outputdir = $self->_read('outputdir', sub { dirname($self->builddir) });
return $outputdir;
}
sub stagingdir {
my $self = shift;
my $stagingdir = $self->_read('stagingdir',
sub { tempdir('stagingXXXX', DIR => $self->outputdir) });
return $stagingdir;
}
sub shared_objects {
my $self = shift;
my $shared_objects
= $self->_read('shared_objects', sub { $self->_get_shared_objects });
return $shared_objects;
}
sub is_noarch {
my $self = shift;
my $is_noarch = $self->_read('is_noarch', sub { $self->_get_is_noarch });
return $is_noarch;
}
sub module_name {
my $self = shift;
my $module_name
= $self->_read('module_name', sub { $self->_get_module_name });
return $module_name;
}
sub dist_name {
my $self = shift;
return $self->module->package_name;
}
sub name {
my $self = shift;
my $name = $self->_read('name',
sub { $self->_normalize_name($self->dist_name) });
return $name;
}
sub dist_version {
my $self = shift;
return $self->module->package_version;
}
sub version {
my $self = shift;
my $version = $self->_read('version',
sub { $self->_normalize_version($self->dist_version) });
return $version;
}
sub build_number {
my $self = shift;
return $self->{build_number};
}
sub author {
my $self = shift;
my $author = $self->_read('author', sub { $self->_get_author });
return $author;
}
sub packager {
my $self = shift;
my $packager = $self->_read('packager', sub { $self->_get_packager });
return $packager;
}
sub vendor {
my $self = shift;
my $vendor = $self->_read('vendor', sub { $self->_get_vendor });
return $vendor;
}
sub url {
my $self = shift;
# A link to MetaCPAN is more useful than the homepage.
my $url = $self->_read('url',
sub { 'https://metacpan.org/dist/' . $self->dist_name });
return $url;
}
sub summary {
my $self = shift;
my $summary = $self->_read('summary', sub { $self->_get_summary });
return $summary;
}
sub description {
my $self = shift;
my $description
= $self->_read('description', sub { $self->_get_description });
return $description;
}
sub dependencies {
my $self = shift;
my $dependencies
= $self->_read('dependencies', sub { $self->_get_dependencies });
return $dependencies;
}
sub copyrights {
my $self = shift;
my $copyrights = $self->_read('copyrights', sub { $self->_get_copyrights });
return $copyrights;
}
sub licenses {
my $self = shift;
my $licenses = $self->_read('licenses', sub { $self->_get_licenses });
return $licenses;
}
sub license {
my $self = shift;
my $license = $self->_read('license', sub { $self->_get_license });
return $license;
}
sub files {
my $self = shift;
my $files = $self->_read('files',
sub { [@{$self->_get_docfiles}, @{$self->_get_stagingfiles}] });
return $files;
}
sub files_by_type {
my ($self, $type) = @_;
my @files = map { $_->{name} } grep { $_->{type} eq $type } @{$self->files};
return \@files;
}
sub mb_opt {
my $self = shift;
my $installdirs = $self->installdirs;
return << "END_MB_OPT";
--installdirs $installdirs
END_MB_OPT
}
sub mm_opt {
my $self = shift;
my $installdirs = $self->installdirs;
return << "END_MM_OPT";
INSTALLDIRS=$installdirs
END_MM_OPT
}
sub sanitize_stagingdir {
my $self = shift;
my $fail_count = 0;
my $finddepth = sub {
my $dir = shift;
opendir my $dh, $dir
or croak "Could not traverse '$dir': $OS_ERROR";
ENTRY:
while (defined(my $entry = readdir $dh)) {
next ENTRY if $entry eq q{.} || $entry eq q{..};
my $path = catfile($dir, $entry);
# Skip symbolic links.
next ENTRY if -l $path;
# Process sub directories first.
if (-d $path) {
__SUB__->($path);
}
# Sanitize the permissions.
my @stat = lstat $path;
if (!@stat) {
error("Could not stat '$path': $OS_ERROR");
next ENTRY;
}
my $old_mode = $stat[2] & oct '0777';
my $new_mode = ($old_mode & oct '0755') | oct '0200';
if ($old_mode != $new_mode) {
if (!chmod $new_mode, $path) {
error("Could not chmod '$path': $OS_ERROR");
++$fail_count;
}
}
# Remove empty directories and some files.
if (-d $path) {
rmdir $path;
}
else {
if ( $entry eq 'perllocal.pod'
|| $entry eq '.packlist'
|| $entry =~ m{[.]la \z}xms
|| ($entry =~ m{[.]bs \z}xms && -z $path))
{
if (!unlink $path) {
error("Could not remove '$path': $OS_ERROR");
++$fail_count;
}
}
}
}
closedir $dh;
return;
};
$finddepth->($self->stagingdir);
return $fail_count == 0;
}
sub remove_stagingdir {
my $self = shift;
my $stagingdir = $self->{stagingdir};
if (defined $stagingdir) {
remove_tree($stagingdir);
delete $self->{stagingdir};
}
return 1;
}
sub rpm_cmd {
my $self = shift;
state $rpm_cmd = can_run('rpm');
return $rpm_cmd;
}
sub rpm_eval {
my ($self, $expr) = @_;
my $string = q{};
my $rpm_cmd = $self->rpm_cmd;
if ($rpm_cmd) {
my @eval_cmd = ($rpm_cmd, '--eval', $expr);
my $output = q{};
if (run(command => \@eval_cmd, buffer => \$output)) {
chomp $output;
$string = eval { decode_utf8($output) } // q{};
}
}
return $string;
}
sub sudo_cmd {
my $self = shift;
my $module = $self->module;
my $backend = $module->parent;
my $config = $backend->configure_object;
my $sudo_cmd = $config->get_program('sudo') // 'sudo';
return $sudo_cmd;
}
sub DESTROY {
my $self = shift;
my $stagingdir = $self->{stagingdir};
if (defined $stagingdir) {
##no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
eval { remove_tree($stagingdir) };
}
return;
}
## no critic (Subroutines::ProhibitExcessComplexity)
sub _normalize_name {
my ($self, $dist_name) = @_;
my $name;
if (exists $PACKAGE_NAME_FOR{$dist_name}) {
$name = $PACKAGE_NAME_FOR{$dist_name};
}
else {
$name = $dist_name;
# Prepend "perl-" unless the name starts with "perl-".
if ($name !~ m{\A perl-}xms) {
$name = 'perl-' . $name;
}
}
return $name;
}
sub _normalize_version {
my ($self, $dist_version) = @_;
my $dist_name = $self->dist_name;
my $version = $dist_version // 0;
if (exists $VERSION_FOR{$dist_name}) {
$version = $VERSION_FOR{$dist_name}->($version);
}
$version =~ s{\A v}{}xms; # Strip "v".
$version =~ s/[-_]/~/g; # Handle release candidates.
return $version;
}
sub _unnumify_version {
my ($self, $dist_version) = @_;
my $version
= $self->_normalize_version(parse_version($dist_version)->normal);
return $version;
}
sub _get_meta {
my $self = shift;
my $meta;
my $builddir = $self->builddir;
META:
for (qw(META.json META.yml)) {
my $metafile = catfile($builddir, $_);
if (-f $metafile) {
$meta = eval { CPAN::Meta->load_file($metafile) };
last META if defined $meta;
}
}
return $meta;
}
sub _meta {
my $self = shift;
my $meta = $self->_read('meta', sub { $self->_get_meta });
return $meta;
}
sub _get_pod {
my $self = shift;
my $builddir = $self->builddir;
my $name = $POD_FOR{$self->dist_name} // $self->module_name;
my @dirs = map { catdir($builddir, $_) } qw(blib/lib blib/bin lib bin .);
my $pod = CPANPLUS::Dist::Debora::Pod->find($name, @dirs, $builddir);
return $pod;
}
sub _pod {
my $self = shift;
return $self->_read('pod', sub { $self->_get_pod });
}
sub _get_shared_objects {
my $self = shift;
my $stagingdir = $self->{stagingdir};
if (!defined $stagingdir) {
croak 'Call shared_objects after the distribution has been built';
}
my $shared_objects = find_shared_objects($stagingdir);
return $shared_objects;
}
sub _get_is_noarch {
my $self = shift;
# Searching for source code files isn't reliable as there are Perl
# distributions with C files in example directories.
#
# Instead, we look for an "auto" directory and search for shared objects
# after the distribution has been installed in the staging directory.
my $stagingdir = $self->{stagingdir};
if (!defined $stagingdir) {
croak 'Call is_arch after the distribution has been built';
}
my $is_noarch = @{$self->shared_objects} == 0;
if ($is_noarch) {
my $installdirs = $self->installdirs;
my $archdir = $Config{"install${installdirs}arch"};
if (defined $archdir) {
my $autodir = catdir($stagingdir, $archdir, 'auto');
if (-d $autodir) {
$is_noarch = 0;
}
}
}
return $is_noarch;
}
sub _get_module_name {
my $self = shift;
my $name = $self->module->module;
# Is there a .pm file with the distribution's name?
my @module = split qr{-}xms, $self->dist_name;
my $filename = catfile($self->builddir, 'lib', @module) . '.pm';
if (-f $filename) {
$name = join q{::}, @module;
}
return $name;
}
sub _get_author {
my $self = shift;
my $name;
my $author = $self->module->author;
if (defined $author && ref $author ne 'CPANPLUS::Module::Author::Fake') {
$name = $author->author;
}
return $name;
}
sub _get_packager {
my $self = shift;
my $name;
my $email;
my $EMAIL = qr{ \A
(?:([^<]*) \h+)? # name
<? ([^>]+@[^>]+) >? # email
}xms;
if ($self->rpm_eval('%{?packager}') =~ $EMAIL) {
$name = $1;
$email = $2;
}
if (!$name) {
NAME:
for my $key (qw(DEBFULLNAME NAME GITLAB_USER_NAME)) {
if ($ENV{$key}) {
$name = eval { decode_utf8($ENV{$key}) };
last NAME if $name;
}
}
}
for my $key (qw(DEBEMAIL EMAIL GITLAB_USER_EMAIL)) {
if ($ENV{$key}) {
my $value = eval { decode_utf8($ENV{$key}) };
if ($value && $value =~ $EMAIL) {
if (!$name) {
$name = $1;
}
if (!$email) {
$email = $2;
}
}
}
}
my $user;
my @pw = eval { getpwuid $UID };
if (@pw) {
$user = eval { decode_utf8($pw[0]) };
if (!$name) {
my $gecos = eval { decode_utf8($pw[6]) };
if ($gecos) {
($name) = split qr{,}xms, $gecos;
}
}
}
if (!$user) {
USER:
for my $key (qw(LOGNAME USER USERNAME)) {
if ($ENV{$key}) {
$user = eval { decode_utf8($ENV{$key}) };
last USER if $user;
}
}
}
if (!$user) {
$user = 'nobody';
}
if (!$name) {
$name = $user;
}
if (!$email) {
my $host = hostfqdn;
if (!$host) {
$host = 'localhost';
}
$host =~ s{[.]$}{}xms;
$email = $user . q{@} . $host;
}
return "$name <$email>";
}
sub _get_vendor {
my $self = shift;
my $vendor = $self->rpm_eval('%{?vendor}');
if (!$vendor || $vendor =~ m{%}xms) {
$vendor = 'CPANPLUS';
}
return $vendor;
}
sub _get_summary_from_meta {
my $self = shift;
my $summary;
my $meta = $self->_meta;
if (defined $meta) {
my $text = $meta->{abstract};
if ($text && $text !~ m{unknown}xmsi) {
$summary = $text;
}
}
return $summary;
}
sub _get_summary_from_pod {
my $self = shift;
my $summary;
my $pod = $self->_pod;
if (defined $pod) {
$summary = $pod->summary;
}
return $summary;
}
sub _get_summary {
my $self = shift;
my $summary = $self->_get_summary_from_meta // $self->_get_summary_from_pod
// 'Module for the Perl programming language';
$summary =~ s{\v+}{ }xmsg; # Replace newlines.
$summary =~ s{[.]+ \z}{}xms; # Remove trailing dots.
$summary =~ s{\A (?:An? | The) \h+}{}xmsi; # Remove leading articles.
return ucfirst $summary;
}
sub _get_description {
my $self = shift;
my $description = q{};
my $pod = $self->_pod;
if (defined $pod) {
$description = $pod->description;
}
if (!$description) {
my $module_name = $self->module_name;
$description
= "$module_name is a module for the Perl programming language.";
}
return $description;
}
sub _get_requires {
my $self = shift;
my %requires;
my $prereqs = $self->module->status->prereqs // {};
my $meta = $self->_meta;
if (defined $meta && ref $meta->{prereqs} eq 'HASH') {
my $meta_runtime = $meta->{prereqs}->{runtime} // {};
my $meta_requires = $meta_runtime->{requires} // {};
# We can only have dependencies that are in the prereqs.
%requires = map { $_ => $meta_requires->{$_} }
grep { exists $prereqs->{$_} } keys %{$meta_requires};
}
else {
%requires = %{$prereqs};
}
return \%requires;
}
sub _get_dependencies {
my $self = shift;
my %requires = %{$self->_get_requires};
my $backend = $self->module->parent;
# Sometimes versions are numified and cannot be compared with stringified
# versions.
my %version_for = (
'Algorithm::Diff' => sub {0},
'BioPerl' => sub { $self->_unnumify_version($_[0]) },
'Catalyst' => sub {0},
'Catalyst::Runtime' => sub {0},
'CGI::Simple' => sub {0},
'DBD::Pg' => sub { $self->_unnumify_version($_[0]) },
'strict' => sub {0},
'Time::Local' => sub {0},
'warnings' => sub {0},
);
my %dependency;
MODULE:
for my $module_name (keys %requires) {
my $module = $backend->module_tree($module_name);
next MODULE if !$module;
# Task::Weaken is only a build dependency.
next MODULE if $module_name eq 'Task::Weaken';
# Ignore dependencies on modules for VMS and Windows.
next MODULE if $module_name =~ m{\A (?:VMS | Win32)}xms;
my $dist_name = $module->package_name;
my $version = parse_version($requires{$module_name});
my $is_core
= $module_name eq 'perl'
|| module_is_distributed_with_perl($module_name, $version)
|| $module->package_is_perl_core;
if (exists $version_for{$module_name}) {
$version = $version_for{$module_name}->($version);
}
if (!exists $dependency{$module_name}
|| $dependency{$module_name}->{version} < $version)
{
$dependency{$module_name} = {
dist_name => $dist_name,
version => $version,
is_module => $module_name ne 'perl',
is_core => $is_core,
};
}
}
my @dependencies = map { {
module_name => $_,
dist_name => $dependency{$_}->{dist_name},
package_name => $self->_normalize_name($dependency{$_}->{dist_name}),
version => $self->_normalize_version($dependency{$_}->{version}),
is_module => $dependency{$_}->{is_module},
is_core => $dependency{$_}->{is_core},
} } sort { uc $a cmp uc $b } keys %dependency;
return \@dependencies;
}
sub _get_copyrights {
my $self = shift;
my @copyrights;
my $pod = $self->_pod;
if (defined $pod) {
push @copyrights, @{$pod->copyrights};
}
if (!@copyrights) {
my $author = $self->author;
my $holder
= $author ? "$author and possibly others" : 'unknown authors';
my $time = $self->last_modification;
my $year = (gmtime $time)[5] + 1900;
push @copyrights, {year => $year, holder => $holder};
}
return \@copyrights;
}
sub _get_licenses_from_meta {
my $self = shift;
my @licenses;
my $meta = $self->_meta;
if (defined $meta) {
my $keys = $meta->{license};
if (defined $keys) {
if (!ref $keys) {
$keys = [$keys];
}
my %ignore_key = map { $_ => 1 } qw(open_source unrestricted);
for my $key (grep { !exists $ignore_key{$_} } @{$keys}) {
my @license
= Software::LicenseUtils->guess_license_from_meta_key($key,
2);
if (@license) {
push @licenses, @license;
}
}
}
}
return \@licenses;
}
sub _get_licenses_from_pod {
my $self = shift;
my @licenses;
my $pod = $self->_pod;
if (defined $pod) {
my @license
= Software::LicenseUtils->guess_license_from_pod($pod->text);
if (@license) {
push @licenses, @license;
}
}
return \@licenses;
}
sub _get_licenses {
my $self = shift;
my %copyright = %{$self->copyrights->[-1]};
my $get_license = sub {
my $spdx_expression = shift;
my $license = eval {
Software::LicenseUtils->new_from_spdx_expression({
spdx_expression => $spdx_expression,
%copyright
});
};
if (!$license) {
$license = CPANPLUS::Dist::Debora::License->new({
package => $self,
%copyright
});
}
return $license;
};
my %unique_guesses
= map { $_->name => $_ } @{$self->_get_licenses_from_meta},
@{$self->_get_licenses_from_pod};
# Add the copyright year and author to the guessed licenses.
my @licenses
= map { $get_license->($_->spdx_expression) } values %unique_guesses;
if (!@licenses) {
push @licenses, $get_license->($LICENSE_FOR{$self->dist_name});
}
my @sorted_licenses
= sort { $a->spdx_expression cmp $b->spdx_expression } @licenses;
return \@sorted_licenses;
}
sub _get_license {
my $self = shift;
my @names = map { $_->spdx_expression } @{$self->licenses};
my $license = join ' AND ',
map { @names > 1 && m{\b OR \b}xmsi ? "($_)" : $_ } @names;
return $license;
}
sub _get_docfiles {
my $self = shift;
my $LICENSE = qr{ \A (?:
COPYING(?:[.](?:LESSER|LIB))?
| COPYRIGHT
| LICEN[CS]E
) (?:[.](?:md|mkdn|pod|txt))? \z
}xmsi;
my $CHANGELOG = qr{ \A (?:
Change(?:s|Log)
) (?:[.](?:md|mkdn|pod|txt))? \z
}xmsi;
my $DOC = qr{ \A (?:
AUTHORS
| BUGS
| CONTRIBUTING
| CREDITS
| FAQ
| NEWS
| README
| THANKS
| TODO
) (?:[.](?:md|mkdn|pod|txt))? \z
}xmsi;
my %regex_for = (
'license' => $LICENSE,
'changelog' => $CHANGELOG,
'doc' => $DOC,
);
my @files;
my $fix_permissions = sub {
my $dir = shift;
chmod oct '0755', $dir;
opendir my $dh, $dir
or croak "Could not traverse '$dir': $OS_ERROR";
ENTRY:
while (defined(my $entry = readdir $dh)) {
next ENTRY if $entry eq q{.} || $entry eq q{..};
my $path = catfile($dir, $entry);
# Skip symbolic links.
next ENTRY if -l $path;
if (-d $path) {
__SUB__->($path);
}
else {
chmod oct '0644', $path;
}
}
closedir $dh;
return;
};
my $find = sub {
my $dir = shift;
opendir my $dh, $dir
or croak "Could not traverse '$dir': $OS_ERROR";
ENTRY:
while (defined(my $entry = readdir $dh)) {
next ENTRY if $entry eq q{.} || $entry eq q{..};
my $path = catfile($dir, $entry);
# Skip symbolic links.
next ENTRY if -l $path;
if (-d $path) {
if ($entry eq 'examples') {
$fix_permissions->($path);
my $file = {name => $entry, type => 'doc'};
push @files, $file;
}
}
elsif (-s $path) {
TYPE:
for my $type (keys %regex_for) {
if ($entry =~ $regex_for{$type}) {
chmod oct '0644', $path;
my $file = {name => $entry, type => $type};
push @files, $file;
last TYPE;
}
}
}
}
closedir $dh;
return;
};
$find->($self->builddir);
my @sorted_files = sort { $a->{name} cmp $b->{name} } @files;
return \@sorted_files;
}
sub _get_excludedirs {
my $self = shift;
# A list of directories that are provided by Perl and must not be removed
# by packages.
my @vars = qw(
installsitearch
installsitebin
installsitelib
installsiteman1dir
installsiteman3dir
installsitescript
installvendorarch
installvendorbin
installvendorlib
installvendorman1dir
installvendorman3dir
installvendorscript
);
my %excludedirs = map { $_ => 1 } qw(/etc);
VAR:
for my $var (@vars) {
my $value = $Config{$var};
next VAR if !$value;
if ($var =~ m{arch \z}xms) {
$value = catdir($value, 'auto');
}
my ($volume, $path) = File::Spec->splitpath($value, 1);
my ($dir, @dirs) = splitdir($path);
while (@dirs) {
$dir = catdir($dir, shift @dirs);
$excludedirs{$dir} = 1;
}
}
return \%excludedirs;
}
sub _get_stagingfiles {
my $self = shift;
my $stagingdir = $self->stagingdir;
my $stagingdir_length = length $stagingdir;
my $excludedirs = $self->_get_excludedirs;
my @files;
my $find = sub {
my $dir = shift;
opendir my $dh, $dir
or croak "Could not traverse '$dir': $OS_ERROR";
ENTRY:
while (defined(my $entry = readdir $dh)) {
next ENTRY if $entry eq q{.} || $entry eq q{..};
my $path = catfile($dir, $entry);
my $name = substr $path, $stagingdir_length;
my $type = -l $path ? 'link' : -d $path ? 'dir' : 'file';
if ($type eq 'file') {
my ($volume, $dirs, $file) = splitpath($name);
my %subdir = map { $_ => 1 } splitdir($dirs);
if (exists $subdir{etc}) {
$type = 'config';
}
elsif (exists $subdir{man}) {
$type = 'man';
}
}
if (!exists $excludedirs->{$name}) {
my $file = {name => $name, type => $type};
push @files, $file;
}
# Skip symbolic links.
next ENTRY if -l $path;
if (-d $path) {
__SUB__->($path);
}
}
closedir $dh;
return;
};
$find->($stagingdir);
my @sorted_files = sort { $a->{name} cmp $b->{name} } @files;
return \@sorted_files;
}
1;
__END__
=encoding UTF-8
=head1 NAME
CPANPLUS::Dist::Debora::Package - Base class for package formats
=head1 VERSION
version 0.018
=head1 SYNOPSIS
use parent qw(CPANPLUS::Dist::Debora::Package);
my $name = $package->name;
my $version = $package->version;
my $summary = $package->summary;
my $description = $package->description;
my @licenses = @{$package->licenses};
my @dependencies = @{$package->dependencies};
my @files = @{$package->files};
=head1 DESCRIPTION
This module collects information on a yet to be created Debian or RPM package.
The information is obtained from a L<CPANPLUS::Module> object, the file system
and the environment. Among other things, the module gets the package name, a
short summary, a description, the license and the dependencies.
=head1 SUBROUTINES/METHODS
Any methods marked I<Abstract> must be implemented by subclasses.
=head2 new
my $package = CPANPLUS::Dist::Debora::Package->new(
module => $module,
installdirs => 'vendor',
build_number => 1,
);
Creates a new object. The L<CPANPLUS::Module> object parameter is mandatory.
All other attributes are optional.
=head2 format_priority I<Abstract>
my $priority = CPANPLUS::Dist::Debora::Package->format_priority;
Checks whether the package format is available. Returns 0 if the required
package tools are not available, 1 if the tools are available and 2 or higher
if the format is the operating system's native format.
=head2 create I<Abstract>
my $ok = $package->create(verbose => 0|1);
Creates a package.
=head2 install I<Abstract>
my $ok = $package->install(verbose => 0|1);
Installs the package.
=head2 outputname I<Abstract>
my $outputname = $package->outputname;
Returns the package filename, e.g.
F<~/rpmbuild/RPMS/noarch/perl-Some-Module-1.0-1.noarch.rpm>.
=head2 module
my $module = $package->module;
Returns the L<CPANPLUS::Module> object that was passed to the constructor.
=head2 installdirs
my $installdirs = $package->installdirs;
Returns the installation location, which can be "vendor" or "site". Defaults
to "vendor".
=head2 sourcefile
my $sourcefile = $package->sourcefile;
Returns the path to the Perl distribution's source archive, e.g.
F<~/.cpanplus/authors/id/S/SO/SOMEBODY/Some-Module-1.0.tar.gz>.
=head2 sourcedir
my $sourcedir = $package->sourcedir;
Returns the path to the Perl distribution's source directory, e.g.
F<~/.cpanplus/authors/id/S/SO/SOMEBODY>.
=head2 last_modification
my $timestamp = $package->last_modification;
Returns the last modification time of the source.
=head2 builddir
my $builddir = $package->builddir;
Returns the directory the source archive was extracted to, e.g.
F<~/.cpanplus/5.36.1/build/XXXX/Some-Module-1.0>.
=head2 outputdir
my $outputdir = $package->outputdir;
Returns the build directory's parent directory, e.g.
F<~/.cpanplus/5.36.1/build/XXXX>.
=head2 stagingdir
my $stagingdir = $package->stagingdir;
Returns the staging directory where CPANPLUS installs the Perl distribution,
e.g. F<~/.cpanplus/5.36.1/build/XXXX/stagingYYYY>.
=head2 shared_objects
for my $shared_object (@{$package->shared_objects}) {
say $shared_object;
}
Returns a list of shared object files in the staging directory.
This method must only be called after the distribution has been built.
=head2 is_noarch
my $is_no_arch = $package->is_noarch;
Returns true if the package is independent of the hardware architecture.
This method must only be called after the distribution has been built.
=head2 module_name
my $module_name = $package->module_name;
Returns the name of the package's main module, e.g. "Some::Module".
=head2 dist_name
my $dist_name = $package->dist_name;
Returns the Perl distribution's name, e.g. "Some-Module".
=head2 name
my $name = $package->name;
Returns the package name, e.g. "perl-Some-Module" or "libsome-module-perl".
=head2 dist_version
my $dist_name = $package->dist_name;
Returns the Perl distribution's version.
=head2 version
my $version = $package->version;
Returns the package version.
=head2 build_number
my $build_number = $package->build_number;
Returns the build number. Defaults to 1.
The Debian revision and RPM release starts with the build number.
=head2 author
my $author = $package->author;
Returns the name of the Perl distribution's author.
=head2 packager
my $packager = $package->packager;
Returns the packager's name and email address. Taken from the RPM macro
%packager, the environment variables C<DEBFULLNAME>, C<DEBEMAIL>, C<NAME>,
C<EMAIL> or the password database. All environment variables and files have
to be encoded in ASCII or UTF-8.
=head2 vendor
my $vendor = $package->vendor;
Returns "CPANPLUS" or the value of the RPM macro C<%vendor>.
=head2 url
my $url = $package->url;
Returns a web address that links to the Perl distribution's documentation,
e.g. "https://metacpan.org/dist/Some-Module".
=head2 summary
my $summary = $package->summary;
Returns the Perl distribution's one-line description.
=head2 description
my $description = $package->description;
Returns the Perl distribution's description.
=head2 dependencies
for my $dependency (@{$package->dependencies}) {
my $module_name = $dependency->{module_name};
my $dist_name = $dependency->{dist_name};
my $package_name = $dependency->{package_name};
my $version = $dependency->{version};
my $is_core = $dependency->{is_core};
my $is_module = $dependency->{is_module};
}
Builds a list of Perl modules that the package depends on.
=head2 copyrights
for my $copyright (@{$package->copyrights}) {
my $year = $copyright->{year};
my $holder = $copyright->{holder};
}
Returns the copyright years and holders.
=head2 licenses
for my $license (@{$package->licenses}) {
my $full_text = $license->license;
}
Returns L<Software::License> objects.
=head2 license
my $license = $package->license;
Returns a license identifier, e.g. "Artistic-1.0-Perl OR GPL-1.0-or-later".
Returns "Unknown" if no license information was found.
=head2 files
for my $file (@{$package->files}) {
my $name = $file->{name};
my $type = $file->{type};
}
Builds a list of files that CPANPLUS installed in the staging directory.
Searches the build directory for README, LICENSE and other documentation
files.
Possible types are "changelog", "config", "dir", "doc", "file", "license",
"link" and "man".
=head2 files_by_type
for my $file (@{$package->files_by_type($type)}) {
my $name = $file->{name};
}
Returns all files of the given type.
=head2 mb_opt
local $ENV{PERL_MB_OPT} = $package->mb_opt;
Returns the options that are passed to C<perl Build.PL>.
=head2 mm_opt
local $ENV{PERL_MM_OPT} = $package->mm_opt;
Returns the options that are passed to C<perl Makefile.PL>.
=head2 sanitize_stagingdir
my $ok = $package->sanitize_stagingdir;
Fixes permissions. Removes empty directories and files like F<perllocal.pod>
and F<.packlist>.
=head2 remove_stagingdir
my $ok = $package->remove_stagingdir;
Removes the staging directory.
=head2 rpm_cmd
my $rpm_cmd = $self->rpm_cmd;
Returns the path to the rpm command.
=head2 rpm_eval
my $expr = '%{?packager}';
my $string = $package->rpm_eval($expr);
Evaluates an expression with rpm and returns the result or the empty string.
=head2 sudo_cmd
my $sudo_cmd = $self->sudo_cmd;
Returns the path to the sudo command.
=head1 DIAGNOSTICS
See L<CPANPLUS::Dist::Debora> for diagnostics.
=head1 CONFIGURATION AND ENVIRONMENT
See L<CPANPLUS::Dist::Debora> for supported files and environment variables.
=head1 DEPENDENCIES
Requires the module L<Software::License> from CPAN.
=head1 INCOMPATIBILITIES
None.
=head1 BUGS AND LIMITATIONS
Some operating systems numify Perl distribution versions but not consistently.
This module sticks closely to the version string, which seems to be the most
common approach.
=head1 SEE ALSO
L<CPANPLUS::Dist::Debora::Package::Debian>,
L<CPANPLUS::Dist::Debora::Package::RPM>,
L<CPANPLUS::Dist::Debora::Package::Tar>,
L<CPANPLUS::Dist::Debora::License>,
L<CPANPLUS::Dist::Debora::Pod>,
L<CPANPLUS::Dist::Debora::Util>
=head1 AUTHOR
Andreas Vögele E<lt>voegelas@cpan.orgE<gt>
=head1 LICENSE AND COPYRIGHT
Copyright (C) 2025 Andreas Vögele
This module is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.
=cut