File Coverage

blib/lib/CPANPLUS/Dist/Debora/Package/RPM.pm

Criterion	Covered	Total	%
statement	151	200	75.5
branch	14	44	31.8
condition	2	15	13.3
subroutine	45	48	93.7
pod	14	14	100.0
total	226	321	70.4

package CPANPLUS::Dist::Debora::Package::RPM;

# 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 parent qw(CPANPLUS::Dist::Debora::Package);

use Carp qw(croak);
use Config;
use English qw(-no_match_vars);
use File::Path qw(remove_tree);
use File::Spec::Functions qw(catdir catfile);
use File::Temp qw(tempdir);
use POSIX qw(uname);
use Text::Template 1.22 qw();
use Text::Wrap qw();

use CPANPLUS::Dist::Debora::Util
    qw(can_run run slurp_utf8 spew_utf8 is_testing);
use CPANPLUS::Error qw(error);

# Add some package names.
my %OBSOLETES_FOR = (
    'ack'         => [qw(perl-App-Ack)],
    'Alien-Build' => [qw{
        perl-Alien-Base
        perl-Alien-Build-Plugin-Decode-HTML
        perl-Alien-Build-Plugin-Decode-Mojo
        perl-Alien-Build-tests
    }],
    'App-Licensecheck'    => [qw(perl-App-Licensecheck)],
    'App-perlbrew'        => [qw(perl-App-perlbrew)],
    'Catalyst-Runtime'    => [qw{perl-Catalyst-Runtime-scripts}],
    'Encode'              => [qw{perl-Encode-devel perl-encoding}],
    'Module-CoreList'     => [qw{perl-Module-CoreList-tools}],
    'Mojolicious'         => [qw(perl-Test-Mojo)],
    'Perl-Critic'         => [qw(perl-Test-Perl-Critic-Policy)],
    'perl-ldap'           => [qw(perl-LDAP)],
    'Perl-Tidy'           => [qw(perltidy)],
    'TermReadKey'         => [qw(perl-TermReadKey)],
    'Razor2-Client-Agent' =>
        [qw(perl-Razor-Agent perl-razor-agents razor-agents)],
);

# Add additional capabilities to some packages.
my %PROVIDES_FOR = (
    'libwww-perl' => [qw{
        perl(LWP::Debug::TraceHTTP::Socket)
        perl(LWP::Protocol::http::Socket)
        perl(LWP::Protocol::http::SocketMethods)
    }],
    'Moose'            => [qw{perl(Moose::Conflicts)}],
    'Package-Stash'    => [qw{perl(Package::Stash::Conflicts)}],
    'XS-Parse-Keyword' => [qw{perl(:XS_Parse_Keyword_ABI_2)}],
);

sub format_priority {
    my $class = shift;

    my @commands = qw(rpm rpmbuild tar);

    my $priority = 0;
    if (@commands == grep { can_run($_) } @commands) {
        $priority = 1;
        if (-f '/etc/redhat-release' || -d '/usr/lib/rpm/suse') {
            $priority = 2;
        }
    }

    return $priority;
}

sub create {
    my ($self, %options) = @_;

    my $builddir  = $self->builddir;
    my $outputdir = $self->outputdir;
    my $rpmdir    = $self->rpmdir;
    my $sourcedir = $self->sourcedir;
    my $specfile  = catfile($outputdir, $self->name . '.spec');

    my $buildrootdir = tempdir('buildrootXXXX', DIR => $outputdir);

    my @rpmbuild_cmd = (
        'rpmbuild', '-bb',
        '-D',       "_builddir $builddir",
        '-D',       "_rpmdir $rpmdir",
        '-D',       "_sourcedir $sourcedir",
        '-D',       "_buildrootdir $buildrootdir",
        '-D',       'source_date_epoch_from_changelog 0',
        '-D',       'use_source_date_epoch_as_buildtime 1',
        '-D',       'clamp_mtime_to_source_date_epoch 1',
        '--build-in-place',
    );

    if ($self->installdirs eq 'site') {
        my $prefix  = $Config{siteprefix};
        my $datadir = catdir($prefix, 'share');
        push @rpmbuild_cmd, '-D', "_datadir $datadir";
    }

    push @rpmbuild_cmd, $specfile;

    my $ok = 0;

    my $spec = $self->spec;
    if (!$spec) {
        error('Could not render the spec file');
    }
    else {
        $ok = spew_utf8($specfile, $spec);
        if (!$ok) {
            error("Could not create '$specfile': $OS_ERROR");
        }
    }

    if ($ok) {
        local $ENV{SOURCE_DATE_EPOCH} = $ENV{SOURCE_DATE_EPOCH}
            // $self->last_modification;

        $ok = run(
            command => \@rpmbuild_cmd,
            dir     => $builddir,
            verbose => $options{verbose},
        );
    }

    remove_tree($buildrootdir);

    return $ok;
}

sub install {
    my ($self, %options) = @_;

    # We always pass "--force" to rpm.  The CPANPLUS option "force" is more
    # annoying than useful and thus not used here.
    my $sudo_cmd    = $self->sudo_cmd;
    my @install_cmd = ($sudo_cmd, qw(rpm --upgrade --force --verbose));

    if (is_testing) {
        @install_cmd = qw(rpm -qlvp);
    }

    push @install_cmd, $self->outputname;

    my $ok = run(command => \@install_cmd, verbose => $options{verbose});

    return $ok;
}

sub outputname {
    my $self = shift;

    my $outputname = $self->_read(
        'outputname',
        sub {
            catfile($self->rpmdir, $self->arch,
                      $self->name . q{-}
                    . $self->version . q{-}
                    . $self->release . q{.}
                    . $self->arch
                    . q{.rpm});
        }
    );

    return $outputname;
}

sub license {
    my $self = shift;

    my $license = $self->SUPER::license;

    # Fedora's rpmlint expects the licenses in reversed order.
    if ($license eq 'Artistic-1.0-Perl OR GPL-1.0-or-later') {
        $license = 'GPL-1.0-or-later OR Artistic-1.0-Perl';
    }

    return $license;
}

sub rpmdir {
    my $self = shift;

    my $rpmdir = $self->_read('rpmdir', sub { $self->_get_rpmdir });

    return $rpmdir;
}

sub arch {
    my $self = shift;

    my $arch = $self->_read(
        'arch',
        sub {
            $self->is_noarch ? 'noarch' : $self->rpm_eval('%{?_arch}')
                || (uname)[4];
        }
    );

    return $arch;
}

sub dist {
    my $self = shift;

    my $dist = $self->_read('dist', sub { $self->rpm_eval('%{?dist}') });

    return $dist;
}

sub release {
    my $self = shift;

    my $release
        = $self->_read('release', sub { $self->build_number . $self->dist });

    return $release;
}

sub epoch {
    my $self = shift;

    my $epoch = $self->_read('epoch', sub { $self->_get_epoch });

    return $epoch;
}

sub distribution {
    my $self = shift;

    my $distribution
        = $self->_read('distribution', sub { $self->_get_distribution });

    return $distribution;
}

sub provides {
    my $self = shift;

    my $dist_name = $self->dist_name;

    my @provides;
    if (exists $PROVIDES_FOR{$dist_name}) {
        push @provides, @{$PROVIDES_FOR{$dist_name}};
    }

    return \@provides;
}

sub obsoletes {
    my $self = shift;

    my $dist_name = $self->dist_name;

    my @obsoletes;
    if (exists $OBSOLETES_FOR{$dist_name}) {
        push @obsoletes, @{$OBSOLETES_FOR{$dist_name}};
    }

    return \@obsoletes;
}

sub _escape {
    my ($self, $text) = @_;

    if ($text) {
        $text =~ s{%}{%%}xmsg;

        # Insert a non-visible space before "#" characters at the start of
        # a line so that RPM doesn't interpret such lines as comments.
        $text =~ s{^ (\h*) [#]}{$1\N{U+200B}#}xmsg;
    }

    return $text;
}

sub _glob_escape {
    my ($self, $filename) = @_;

    $filename =~ s{([%*?\[\]\\])}{[$1]}xmsg;
    $filename =~ s{[ '{}]}{?}xmsg;

    return $filename;
}

sub _date {
    my ($self, $timestamp) = @_;

    my ($week_day, $month, $day, $time, $year) = split q{ },
        scalar gmtime $timestamp;

    my $date = sprintf '%s %s %02d %s', $week_day, $month, $day, $year;

    return $date;
}

sub _fill_in {
    my ($self, $template, %vars) = @_;

    my $text = $template->fill_in(
        STRICT => 1,
        HASH   => {
            escape      => \sub { $self->_escape(@_) },
            glob_escape => \sub { $self->_glob_escape(@_) },
            package     => \$self,
            date        => $self->_date($self->last_modification),
            %vars
        },
    );

    return $text;
}

sub spec {
    my ($self, %vars) = @_;

    my $template = Text::Template->new(
        DELIMITERS => ['[%', '%]'],
        TYPE       => 'STRING',
        SOURCE     => <<'END_TEMPLATE');
Name:      [% $escape->($package->name) %]
Version:   [% $escape->($package->version) %]
Release:   [% $escape->($package->release) %]
Summary:   [% $escape->($package->summary) %]
License:   [% $escape->($package->license) %]
Packager:  [% $escape->($package->packager) %]
Vendor:    [% $escape->($package->vendor) %]
URL:       [% $escape->($package->url) %]
[%
use Config;

my $perl_version = $Config{version};

my $has_shared_objects = (@{$package->shared_objects} > 0);

my $epoch = $package->epoch;
if ($epoch) {
    $OUT .= 'Epoch:     ' . $escape->($epoch). "\n";
}

my $distribution = $package->distribution;
if ($distribution) {
    $OUT .= '%global distribution '. $escape->($distribution) . "\n";
}

if ($package->is_noarch) {
    $OUT .= "BuildArch: noarch\n";
}

# See "Renaming/Replacing or Removing Existing Packages" in the Fedora
# documentation.
my $evr = $package->version . q{-} . $package->release;
if ($epoch) {
    $evr = $epoch . q{:} . $package->version;
}
my $escaped_evr = $escape->($evr);

for my $name (@{$package->provides}) {
    $OUT .= sprintf "Provides:  %s\n", $escape->($name);
}

for my $name (@{$package->obsoletes}) {
    $OUT .= sprintf "Provides:  %s = %s\n", $escape->($name), $escaped_evr;
    $OUT .= sprintf "Obsoletes: %s < %s\n", $escape->($name), $escaped_evr;
}

$OUT .= "AutoProv:  1\n";

# /usr/lib/rpm/perl.req finds too many circular, internal and optional
# dependencies, but we have to add shared library dependencies to
# architecture-dependent Perl distributions.
if ($package->is_noarch) {
    $OUT .= "AutoReq:   0\n";
}
else {
    $OUT .= "%global _enable_debug_packages 0\n";
    $OUT .= "%global __perl_requires /bin/true\n";
    $OUT .= "%global __perllib_requires /bin/true\n";
    $OUT .= "%global __perltest_requires /bin/true\n";
    $OUT .= "AutoReq:   1\n";
}

$OUT .= "%if 0%{?fedora} > 0 || 0%{?rhel} > 0\n";
if ($has_shared_objects) {
    $OUT .= 'Requires:  perl(:MODULE_COMPAT_' . $escape->($perl_version) . ")\n";
}
else {
    $OUT .= "Requires:  perl-libs\n";
}
$OUT .= "%endif\n";
for my $dependency (@{$package->dependencies}) {
    if ($dependency->{is_module}) {
        $OUT .= 'Requires:  perl(' . $escape->($dependency->{module_name}) . ')';
    }
    else {
        $OUT .= 'Requires:  $escape->($dependency->{package_name})';
    }
    if ($dependency->{version}) {
        $OUT .= ' >= ' . $escape->($dependency->{version});
    }
    $OUT .= "\n";
}
$OUT .= "%{?perl_requires}\n";
q{};
%]
%{?perl_default_filter}

%description
[%
local $Text::Wrap::unexpand = 0;
$escape->(Text::Wrap::wrap(q{}, q{}, $package->description))
%]

%prep

%build

%check

%install
[%
for my $so (@{$package->shared_objects}) {
    $OUT .= "%if %{defined __strip}\n";
    $OUT .= "%{__strip} -g '" . $escape->($so) . "'\n";
    $OUT .= "%endif\n";
}
%]
tar -C '[% $escape->($package->stagingdir) %]' -cf - . | tar -C %{buildroot} -xf -

%clean

%files
%defattr(-, root, root)
[%
my %format = (
    'changelog' => '%%doc %s',
    'config'    => '%%config(noreplace) %s',
    'dir'       => '%%dir %s',
    'doc'       => '%%doc %s',
    'license'   => '%%license %s',
    'man'       => '%s*',
);
for my $file (@{$package->files}) {
    my $name = $file->{name};
    my $type = $file->{type};
    if (exists $format{$type}) {
        $OUT .= sprintf $format{$type}, $glob_escape->($name);
    }
    else {
        $OUT .= $glob_escape->($name);
    }
    $OUT .= "\n";
}
q{};
%]
%changelog
* [% $date %] [% $escape->($package->packager) %] - [% $escape->($package->version) %]-[% $escape->($package->build_number) %]
- Package [% $escape->($package->dist_name) %] [% $escape->($package->version) %]
END_TEMPLATE

    my $text = $self->_fill_in($template, %vars);

    return $text;
}

sub _get_rpmdir {
    my $self = shift;

    my $topdir = $self->rpm_eval('%{?_topdir}');

    if (!$topdir) {
        my $homedir = $ENV{HOME};
        if ($homedir) {
            $topdir = catdir($homedir, 'rpmbuild');
        }
    }

    if (!$topdir) {
        $topdir = $self->outputdir;
    }

    my $rpmdir = catdir($topdir, 'RPMS');

    return $rpmdir;
}

sub _get_epoch_from_env {
    my $self = shift;

    my $epoch = 0;
    if (defined $ENV{EPOCH} && $ENV{EPOCH} =~ m{\A \d+ \z}xms) {
        $epoch = $ENV{EPOCH};
    }

    return $epoch;
}

sub _get_epoch_from_system {
    my $self = shift;

    my $epoch   = 0;
    my $rpm_cmd = $self->rpm_cmd;
    if ($rpm_cmd) {
        my @query_cmd = ($rpm_cmd, '-q', '--qf', '%{EPOCH}', $self->name);
        my $output    = q{};

        my $ok = run(
            command  => \@query_cmd,
            buffer   => \$output,
            on_error => sub { }
        );
        if ($ok) {
            chomp $output;
            if ($output =~ m{\A \d+ \z}xms) {
                $epoch = $output;
            }
        }
    }

    return $epoch;
}

sub _get_epoch {
    my $self = shift;

    my $epoch_env = $self->_get_epoch_from_env;
    my $epoch_sys = $self->_get_epoch_from_system;
    my $epoch     = $epoch_env > $epoch_sys ? $epoch_env : $epoch_sys;

    return $epoch;
}

sub _get_distribution {
    my $self = shift;

    # Values with escaped characters are deliberately ignored.
    my $BRACKETED_REST = qr{[(] [^\\"]*}xms;
    my $PRETTY_NAME
        = qr{^ PRETTY_NAME = " ([^\\"]+?) \h* (?:$BRACKETED_REST)? " $}xms;

    my $distribution = $self->rpm_eval('%{?distribution}');
    if (!$distribution) {
        OS_RELEASE:
        for my $filename (grep {-f} qw(/etc/os-release /usr/lib/os-release)) {
            my $os_release = eval { slurp_utf8($filename) };
            if ($os_release && $os_release =~ $PRETTY_NAME) {
                $distribution = $1;
                last OS_RELEASE;
            }
        }
    }

    return $distribution;
}

1;
__END__