File Coverage

blib/lib/CPANPLUS/Dist/Fedora.pm

Criterion	Covered	Total	%
statement	42	271	15.5
branch	0	50	0.0
condition	0	6	0.0
subroutine	14	36	38.8
pod	5	5	100.0
total	61	368	16.5

#
# This file is part of CPANPLUS::Dist::Fedora.
# Copyright (c) 2007 Jerome Quelin, all rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#

package CPANPLUS::Dist::Fedora;
$CPANPLUS::Dist::Fedora::VERSION = '0.4.4';
use strict;
use warnings;

use parent 'CPANPLUS::Dist::Base';

use Cwd qw[ cwd ];
use CPANPLUS::Error qw[ error msg ];
use File::Basename qw[ basename dirname ];
use File::Copy qw[ copy ];
use IPC::Cmd qw[ run can_run ];
use List::Util qw[ first min ];
use Path::Tiny qw[ path ];
use Pod::POM             ();
use Pod::POM::View::Text ();
use POSIX qw[ strftime ];
use Template ();

$CPANPLUS::Dist::Fedora::_testme = 0;

sub _get_spec_perl_exe
{
    return 'perl';
}

sub _get_spec_template
{
    # Dealing with DATA gets increasingly messy, IMHO
    # So we're going to use the Template Toolkit instead
    return <<'END_SPEC';
[% SET makefile_pl_common = "INSTALLDIRS=vendor NO_PERLLOCAL=1 NO_PACKLIST=1" %]
[% BLOCK rpm_req_wrap %][%- rpm_prefix %] [% rpm_req(br) -%][%- IF (brs.$br != 0) %] >= [% brs.$br %][% END -%][%- "\n" -%][% END %]
Name:       [% status.rpmname %]
Version:    [% status.distvers %]
Release:    [% status.rpmvers %]%{?dist}
License:    [% status.license %]
Summary:    [% status.summary %]
Source:     https://cpan.metacpan.org/[% module.path %]/[% status.distname %]-%{version}.[% module.package_extension %]
Url:        http://metacpan.org/release/[% status.distname %]
Requires:  perl(:MODULE_COMPAT_%(eval "`[% perl_exe %] -V:version`"; echo $version))
[% IF status.is_noarch %]BuildArch:  noarch[% END %]
[% brs = buildreqs; FOREACH br = brs.keys.sort -%]
[% INCLUDE rpm_req_wrap br = br , rpm_prefix = "Requires:" %]
[% END -%]
BuildRequires: coreutils
BuildRequires: make
BuildRequires: perl(ExtUtils::MakeMaker) >= 6.76
BuildRequires: perl-devel
BuildRequires: perl-generators
BuildRequires: perl-interpreter
[% FOREACH br = brs.keys.sort -%]
[% INCLUDE rpm_req_wrap br = br , rpm_prefix = "BuildRequires:" %]
[% END -%]


%description
[% status.description -%]


%prep
%setup -q -n [% status.distname %]-%{version}

%build
[% IF (!status.is_noarch) -%]
[% perl_exe %] Makefile.PL [% makefile_pl_common %] OPTIMIZE="%{optflags}"
[% ELSE -%]
[% perl_exe %] Makefile.PL [% makefile_pl_common %]
[% END -%]
%{make_build}

%install
%{make_install}
[% IF 0 -%]
find %{buildroot} -type f \( -name .packlist -o -name perllocal.pod \) -exec rm -f {} ';'
[%- END -%]
[% IF (!status.is_noarch) -%]
find %{buildroot} -type f -name '*.bs' -empty -delete
[% END -%]
[% IF 0 -%]
find %{buildroot} -depth -type d -exec rmdir {} 2>/dev/null ';'
[% END %]

%{_fixperms} %{buildroot}/*

%check
make test

%files
[%- IF 0 -%]
%defattr(-,root,root,-)[% "\n" %]
[%- END -%]
[%- IF licensefiles %][% "\n" %]%license [% licensefiles _ "\n" %][%- END -%]
[% "\n" %]%doc [% docfiles %]
[% IF (status.is_noarch) -%]
%{perl_vendorlib}/*
[% ELSE -%]
%{perl_vendorarch}/*
%exclude %dir %{perl_vendorarch}/auto
[% END -%]
%{_mandir}/man3/*.3*
[% distextra %]

%changelog
* [% date %] [% packager %] [% status.distvers %]-[% status.rpmvers %]
- initial Fedora packaging
- generated with cpan2dist (CPANPLUS::Dist::Fedora version [% packagervers %])
END_SPEC
}

#--
# class methods

#
# my $bool = CPANPLUS::Dist::Fedora->format_available;
#
# Return a boolean indicating whether or not you can use this package to
# create and install modules in your environment.
#
sub format_available
{
    # Check Fedora release file
    if ( not( -f '/etc/fedora-release' or -f '/etc/redhat-release' ) )
    {
        error('Not on a Fedora system');
        return;
    }

    my $flag;

    # check prereqs
    for my $prog (qw[ rpm rpmbuild gcc ])
    {
        next if can_run($prog);
        error("'$prog' is a required program to build Fedora packages");
        $flag++;
    }

    return not $flag;
}

#--
# public methods

#
# my $bool = $fedora->init;
#
# Sets up the C object for use, and return true if
# everything went fine.
#
sub init
{
    my ($self) = @_;
    my $status = $self->status;    # an Object::Accessor
                                   # distname: Foo-Bar
                                   # distvers: 1.23
                                   # extra_files: qw[ /bin/foo /usr/bin/bar ]
                                   # rpmname:     perl-Foo-Bar
      # rpmpath:     $RPMDIR/RPMS/noarch/perl-Foo-Bar-1.23-1mdv2008.0.noarch.rpm
      # rpmvers:     1
      # rpmdir:      $DIR
      # srpmpath:    $RPMDIR/SRPMS/perl-Foo-Bar-1.23-1mdv2008.0.src.rpm
      # specpath:    $RPMDIR/SPECS/perl-Foo-Bar.spec
      # is_noarch:   true if pure-perl
      # license:     try to figure out the actual license
      # summary:     one-liner summary
      # description: a paragraph summary or so
    $status->mk_accessors(
        qw[ distname distvers extra_files rpmname rpmpath rpmvers rpmdir
            srpmpath specpath is_noarch license summary description
        ]
    );

    # This is done to initialise it.
    $self->_get_current_dir();

    return 1;
}

sub _calc_spec_text
{
    my $self   = shift;
    my $module = $self->parent;                         # CPANPLUS::Module
    my $tmpl   = Template->new( { EVAL_PERL => 1 } );
    my $status = $self->status;                         # Private hash

    my @files = @{ $module->status->files };

    my @basenames =
        map { basename $_ } @files;

    # Files for %doc
    my @docfiles =
        grep { /(?:README|Change(?:s|log))$/i } @basenames;

    my @licensefiles =
        grep { /(?:LICENSE)$/i } @basenames;
    my $spec_template = $self->_get_spec_template();

    my $spec_text = '';

    # Handle build/test/requires
    my $buildreqs = $module->status->prereqs;
    $buildreqs->{'Module::Build::Compat'} = 0
        if _is_module_build_compat($module);

    # Process template into spec
    $tmpl->process(
        \$spec_template,
        {
            status       => $status,
            module       => $module,
            buildreqs    => $buildreqs,
            date         => strftime( "%a %b %d %Y", localtime ),
            perl_exe     => $self->_get_spec_perl_exe(),
            packager     => $self->_get_packager(),
            docfiles     => join( ' ', @docfiles ),
            licensefiles => join( ' ', @licensefiles ),
            rpm_req      => sub {
                my $br = shift;
                return ( ( $br eq 'perl' ) ? $br : "perl($br)" );
            },

            packagervers => $CPANPLUS::Dist::Fedora::VERSION,
            distextra    => join( "\n", @{ $status->extra_files || [] } ),
        },
        \$spec_text,
    );

    $spec_text =~ s/\A\s+//ms;

    my $ret = +{ text => $spec_text, };
    if ($CPANPLUS::Dist::Fedora::_testme)
    {
        die $ret;
    }
    return $ret;
}

sub prepare
{
    my ( $self, %args ) = @_;
    msg("dry-run prepare with makemaker...");
    $self->SUPER::prepare(%args);
    my $status = $self->status;                 # Private hash
    my $module = $self->parent;                 # CPANPLUS::Module
    my $intern = $module->parent;               # CPANPLUS::Internals
    my $conf   = $intern->configure_object;     # CPANPLUS::Configure
    my $distmm = $module->status->dist_cpan;    # CPANPLUS::Dist::MM

    # Parse args.
    my %opts = (
        force   => $conf->get_conf('force'),     # force rebuild
        perl    => $^X,
        verbose => $conf->get_conf('verbose'),
        %args,
    );

    # Dry-run with makemaker: find build prereqs.
    if (0)
    {
        msg("dry-run prepare with makemaker...");
        $self->SUPER::prepare(%args);
    }

    # Compute & store package information
    my $distname = $module->package_name;
    $status->distname($distname);
    $status->distvers( $module->package_version );
    $status->summary( _module_summary($module) );
    $status->description( _module_description($module) );
    $status->license( $self->_module_license($module) );

    #$status->disttop($module->name=~ /([^:]+)::/);
    my $dir = $status->rpmdir( $self->_get_current_dir() );
    $status->rpmvers(1);

    # Cache files
    my @files = @{ $module->status->files };

    # Figure out if we're noarch or not
    $status->is_noarch(
        do
        {
            first { /\.(c|xs)$/i } @files;
            }
        ? 0
        : 1
    );

    my $rpmname = _mk_pkg_name($distname);
    $status->rpmname($rpmname);

    # check whether package has been build.
    if ( my $pkg = $self->_has_been_built( $rpmname, $status->distvers ) )
    {
        my $modname = $module->module;
        msg("already created package for '$modname' at '$pkg'");

        if ( not $opts{force} )
        {
            msg("won't re-spec package since --force isn't in use");

            # c::d::mdv store
            $status->rpmpath($pkg);    # store the path of rpm
                                       # cpanplus api
            $status->prepared(1);
            $status->created(1);
            $status->dist($pkg);
            return $pkg;

            # XXX check if it works
        }

        msg('--force in use, re-specing anyway');

        # FIXME: bump rpm version
    }
    else
    {
        msg("writing specfile for '$distname'...");
    }

    # Compute & store path of specfile.
    $status->specpath("$dir/$rpmname.spec");

    # Prepare our template
    my $text     = $self->_calc_spec_text()->{text};
    my $specpath = path( $status->specpath );
    $specpath->spew_utf8($text);
    print "spec file written $specpath\n";

    if ( $intern->_callbacks->munge_dist_metafile )
    {
        print 'munging...';

        my $orig_contents = _read_file( $status->specpath );
        my $new_contents  = $intern->_callbacks->munge_dist_metafile->(
            $intern, $orig_contents
        );
        _write_file( $status->specpath, $new_contents );
    }

    # copy package.
    my $tarball = "$dir/" . basename $module->status->fetch;
    copy $module->status->fetch, $tarball;

    msg("specfile for '$distname' written");

    # return success
    $status->prepared(1);
    return 1;
}

sub create
{
    my ( $self, %args ) = @_;
    my $status = $self->status;                 # private hash
    my $module = $self->parent;                 # CPANPLUS::Module
    my $intern = $module->parent;               # CPANPLUS::Internals
    my $conf   = $intern->configure_object;     # CPANPLUS::Configure
    my $distmm = $module->status->dist_cpan;    # CPANPLUS::Dist::MM

    # parse args.
    my %opts = (
        force   => $conf->get_conf('force'),     # force rebuild
        perl    => $^X,
        verbose => $conf->get_conf('verbose'),
        %args,
    );

    # check if we need to rebuild package.
    if ( $status->created && defined $status->dist )
    {
        if ( not $opts{force} )
        {
            msg("won't re-build package since --force isn't in use");
            return $status->dist;
        }
        msg('--force in use, re-building anyway');
    }

RPMBUILD:
    {
        # dry-run with makemaker: handle prereqs.
        msg('dry-run build with makemaker...');
        $self->SUPER::create(%args);

        my $spec     = $status->specpath;
        my $distname = $status->distname;
        my $rpmname  = $status->rpmname;

        msg("Building '$distname' from specfile $spec...");

        # dry-run, to see if we forgot some files
        my ( $buffer, $success );
        my $dir = $status->rpmdir;
    DRYRUN:
        {
            local $ENV{LC_ALL} = 'C';
            $success = run(

                #command => "rpmbuild -ba --quiet $spec",
                command => 'rpmbuild -ba '
                    . qq{--define '_sourcedir $dir' }
                    . qq{--define '_builddir $dir'  }
                    . qq{--define '_srcrpmdir $dir' }
                    . qq{--define '_rpmdir $dir'    }
                    . $spec,
                verbose => $opts{verbose},
                buffer  => \$buffer,
            );
        }

        # check if the dry-run finished correctly
        if ($success)
        {
            my ($rpm)  = ( sort glob "$dir/*/$rpmname-*.rpm" )[-1];
            my ($srpm) = ( sort glob "$dir/$rpmname-*.src.rpm" )[-1];
            msg("RPM created successfully: $rpm");
            msg("SRPM available: $srpm");

            # c::d::mdv store
            $status->rpmpath($rpm);
            $status->srpmpath($srpm);

            # cpanplus api
            $status->created(1);
            $status->dist($rpm);
            return $rpm;
        }

        # unknown error, aborting.
        if (
            not $buffer =~
            /^\s+Installed .but unpackaged. file.s. found:\n(.*)\z/ms )
        {
            error("Failed to create Fedora package for '$distname': $buffer");

            # cpanplus api
            $status->created(0);
            return;
        }

        # additional files to be packaged
        msg("extra files installed, fixing spec file");
        my $files = $1;
        $files =~ s/^\s+//mg;    # remove spaces
        my @files = split /\n/, $files;
        $status->extra_files( \@files );
        $self->prepare( %opts, force => 1 );
        msg('restarting build phase');
        redo RPMBUILD;
    }
}

sub install
{
    my ( $self, %args ) = @_;
    my $rpm = $self->status->rpm;
    error("installing $rpm");
    die;

    #$dist->status->installed
}

#--
# Private methods:

sub _read_file
{
    my ($filename) = @_;
    open my $fh, '< :encoding(utf8)', $filename;
    local $/;
    my $contents = <$fh>;
    close($fh);

    return $contents;
}

sub _write_file
{
    my ( $filename, $contents ) = @_;
    open my $fh, '> :encoding(utf8)', $filename;
    print {$fh} $contents;
    close($fh);

    return;
}

#
# my $bool = $self->_has_been_built;
#
# Returns true if there's already a package built for this module.
#
sub _has_been_built
{
    my ( $self, $name, $vers ) = @_;
    my $RPMDIR = $self->_get_RPMDIR();
    my $pkg    = ( sort glob "$RPMDIR/RPMS/*/$name-$vers-*.rpm" )[-1];
    return $pkg;

    # FIXME: should we check cooker?
}

#--
# Private subs

sub _is_module_build_compat
{
    my ($module) = @_;
    my $makefile = $module->_status->extract . '/Makefile.PL';

    open my $mk_fh, "<", $makefile;

    my $found = 0;

LINES:
    while ( my $line = <$mk_fh> )
    {
        if ( $line =~ /Module::Build::Compat/ )
        {
            $found = 1;
            last LINES;
        }
    }

    close($mk_fh);

    return $found;
}

#
# my $name = _mk_pkg_name($dist);
#
# given a distribution name, return the name of the mandriva rpm
# package. in most cases, it will be the same, but some pakcage name
# will be too long as a rpm name: we'll have to cut it.
#
sub _mk_pkg_name
{
    my ($dist) = @_;
    my $name = 'perl-' . $dist;
    return $name;
}

# determine the module license.
#
# FIXME! for now just return the default licence

sub _module_license
{
    my $self   = shift;
    my $module = shift;

    return $self->_get_default_license();
}

sub _get_default_license
{
    return 'CHECK(GPL+ or Artistic)';
}

#
# my $description = _module_description($module);
#
# given a cpanplus::module, try to extract its description from the
# embedded pod in the extracted files. this would be the first paragraph
# of the DESCRIPTION head1.
#
sub _module_description
{
    my ($module) = @_;

    my $path =
        dirname $module->_status->extract;    # where tarball has been extracted
    my @docfiles =
        map { "$path/$_" }                    # prepend extract directory
        sort { length $a <=> length $b } # sort by length: we prefer top-level module description
        grep { /\.(pod|pm)$/ }           # filter out those that can contain pod
        @{ $module->_status->files };    # list of embedded files

    # parse file, trying to find a header
    my $parser = Pod::POM->new;
DOCFILE:
    foreach my $docfile (@docfiles)
    {
        my $pom = $parser->parse_file($docfile);    # try to find some pod
        next DOCFILE
            unless defined $pom;    # the file may contain no pod, that's ok
    HEAD1:
        foreach my $head1 ( $pom->head1 )
        {
            next HEAD1 unless $head1->title eq 'DESCRIPTION';
            my $pom = $head1->content;    # get pod for DESCRIPTION paragraph
            my $text =
                $pom->present('Pod::POM::View::Text');   # transform pod to text
            my @paragraphs = ( split /\n\n/, $text );
            @paragraphs = @paragraphs[ 0 .. min( $#paragraphs, 2 ) ]
                ;    # only the 3 first paragraphs
            return join "\n\n", @paragraphs;
        }
    }

    return 'no description found';
}

#
# my $summary = _module_summary($module);
#
# Given a CPANPLUS::Module, return its registered description (if any)
# or try to extract it from the embedded POD in the extracted files.
#
sub _module_summary
{
    my ($module) = @_;

    # registered modules won't go farther...
    return $module->description if $module->description;

    my $path =
        dirname $module->_status->extract;    # where tarball has been extracted
    my @docfiles =
        map { "$path/$_" }                    # prepend extract directory
        sort { length $a <=> length $b } # sort by length: we prefer top-level module summary
        grep { /\.(pod|pm)$/ }           # filter out those that can contain pod
        @{ $module->_status->files };    # list of files embedded

    # parse file, trying to find a header
    my $parser = Pod::POM->new;
DOCFILE:
    foreach my $docfile (@docfiles)
    {
        my $pom = $parser->parse_file($docfile);    # try to find some pod
        next unless defined $pom;    # the file may contain no pod, that's ok
    HEAD1:
        foreach my $head1 ( $pom->head1 )
        {
            my $title = $head1->title;
            next HEAD1 unless $title eq 'NAME';
            my $content = $head1->content;
            next DOCFILE unless $content =~ /^[^-]+ - (.*)$/m;
            return $1 if $content;
        }
    }

    return 'no summary found';
}

sub _get_RPMDIR
{
    my $self = shift;

    # Memoize it.
    if ( !defined( $self->{_RPMDIR} ) )
    {
        chomp( my $d = qx[ rpm --eval %_topdir ] );
        $self->{_RPMDIR} = $d;
    }

    return $self->{_RPMDIR};
}

sub _get_packager
{
    my $self = shift;

    # Memoize it.
    if ( !defined( $self->{_packager} ) )
    {
        my $d = `rpm --eval '%{packager}'`;
        chomp $d;
        $self->{_packager} = $d;
    }

    return $self->{_packager};
}

sub _get_current_dir
{
    my $self = shift;

    # Memoize it.
    if ( !defined( $self->{_current_dir} ) )
    {
        $self->{_current_dir} = cwd();
    }

    return $self->{_current_dir};
}

1;

__END__