File Coverage

blib/lib/CPANPLUS/Dist/Slackware.pm

Criterion	Covered	Total	%
statement	39	399	9.7
branch	0	178	0.0
condition	0	26	0.0
subroutine	13	37	35.1
pod	5	5	100.0
total	57	645	8.8

package CPANPLUS::Dist::Slackware;

use strict;
use warnings;

our $VERSION = '1.030';

use base qw(CPANPLUS::Dist::Base);

use English qw( -no_match_vars );

use CPANPLUS::Dist::Slackware::PackageDescription;
use CPANPLUS::Dist::Slackware::Util
    qw(can_run run catdir catfile spurt filetype gzip strip);
use CPANPLUS::Error;

use Cwd qw();
use ExtUtils::Packlist;
use File::Find qw();
use Locale::Maketext::Simple ( Style => 'gettext' );
use Module::Pluggable require => 1;
use Params::Check qw();

local $Params::Check::VERBOSE = 1;

my $NONROOT_WARNING = <<'END_NONROOT_WARNING';
In order to manage packages as a non-root user, which is highly recommended,
you must have sudo and, optionally, fakeroot.
END_NONROOT_WARNING

sub format_available {
    my $missing_programs_count = 0;
    for my $program (
        qw(/sbin/makepkg /sbin/installpkg /sbin/upgradepkg /sbin/removepkg))
    {
        if ( !can_run($program) ) {
            error(
                loc(q{You do not have '%1' -- '%2' not available}, $program,
                    __PACKAGE__
                )
            );
            ++$missing_programs_count;
        }
    }
    return ( $missing_programs_count == 0 );
}

sub init {
    my $dist = shift;

    my $status = $dist->status;

    $status->mk_accessors(qw(_pkgdesc _fakeroot_cmd _plugins));

    $status->_fakeroot_cmd( can_run('fakeroot') );

    $status->_plugins( [ grep { $_->available($dist) } $dist->plugins ] );

    return 1;
}

sub prepare {
    my ( $dist, @params ) = @_;

    my $param_ref = $dist->_parse_params(@params) or die;
    my $status    = $dist->status;
    my $module    = $dist->parent;

    my $pkgdesc = CPANPLUS::Dist::Slackware::PackageDescription->new(
        module      => $module,
        installdirs => $param_ref->{installdirs},
    );
    $status->_pkgdesc($pkgdesc);

    $status->dist( $pkgdesc->outputname );

    umask oct '022';

    {

        # CPANPLUS::Dist:MM does not accept multiple options in
        # makemakerflags.  Instead, the options are passed in PERL_MM_OPT.
        # PERL_MB_OPT requires Module::Build 0.36.
        local $ENV{PERL_MM_OPT}   = $dist->_perl_mm_opt;
        local $ENV{PERL_MB_OPT}   = $dist->_perl_mb_opt;
        local $ENV{MODULEBUILDRC} = 'NONE';

        # We are not allowed to write to XML/SAX/ParserDetails.ini.
        local $ENV{SKIP_SAX_INSTALL} = 1;

        $dist->_call_plugins('pre_prepare') or return;

        $dist->SUPER::prepare(@params) or return;

        $dist->_call_plugins('post_prepare') or return;
    }

    return $status->prepared(1);
}

sub create {
    my ( $dist, @params ) = @_;

    my $param_ref = $dist->_parse_params(@params) or return;
    my $status = $dist->status;

    {

        # Some tests fail if PERL_MM_OPT and PERL_MB_OPT are set during the
        # create stage.
        delete local $ENV{PERL_MM_OPT};
        delete local $ENV{PERL_MB_OPT};
        local $ENV{MODULEBUILDRC} = 'NONE';

        $dist->SUPER::create(@params) or return;

        $status->created(0);

        $dist->_fake_install($param_ref) or return;
    }

    $dist->_compress_manual_pages($param_ref) or return;

    $dist->_install_docfiles($param_ref) or return;

    $dist->_process_installed_files($param_ref) or return;

    $dist->_make_installdir($param_ref) or return;

    $dist->_write_slack_desc($param_ref) or return;

    $dist->_call_plugins('pre_package') or return;

    $dist->_write_config_files($param_ref) or return;

    $dist->_makepkg($param_ref) or return;

    return $status->created(1);
}

sub install {
    my ( $dist, @params ) = @_;

    my $param_ref = $dist->_parse_params(@params) or return;
    my $status = $dist->status;

    $dist->_installpkg($param_ref) or return;

    return $status->installed(1);
}

sub _parse_params {
    my ( $dist, %params ) = @_;

    my $module = $dist->parent;
    my $cb     = $module->parent;
    my $conf   = $cb->configure_object;

    my $param_ref;
    {
        local $Params::Check::ALLOW_UNKNOWN = 1;
        my $tmpl = {
            force       => { default => $conf->get_conf('force') },
            verbose     => { default => $conf->get_conf('verbose') },
            keep_source => { default => 0 },
            make        => { default => $conf->get_program('make') },
            perl        => { default => $EXECUTABLE_NAME },
            installdirs => {
                default => $ENV{INSTALLDIRS} || 'vendor',
                allow => [ 'site', 'vendor' ]
            },
        };
        $param_ref = Params::Check::check( $tmpl, \%params ) or return;
    }
    return $param_ref;
}

sub _call_plugins {
    my ( $dist, $method ) = @_;

    my $status = $dist->status;
    my $module = $dist->parent;

    my $orig_dir = Cwd::cwd();
    chdir $module->status->extract or return;

    for my $plugin ( @{ $status->_plugins } ) {
        if ( $plugin->can($method) ) {
            $plugin->$method($dist) or return;
        }
    }

    chdir $orig_dir or return;

    return 1;
}

sub _perl_mm_opt {
    my $dist = shift;

    my $status  = $dist->status;
    my $pkgdesc = $status->_pkgdesc;

    my $installdirs = $pkgdesc->installdirs;
    my $INSTALLDIRS = uc $installdirs;
    my %mandir      = $pkgdesc->mandirs;

    return << "END_PERL_MM_OPT";
INSTALLDIRS=$installdirs
INSTALL${INSTALLDIRS}MAN1DIR=$mandir{1}
INSTALL${INSTALLDIRS}MAN3DIR=$mandir{3}
END_PERL_MM_OPT
}

sub _perl_mb_opt {
    my $dist = shift;

    my $status  = $dist->status;
    my $pkgdesc = $status->_pkgdesc;

    my $installdirs = $pkgdesc->{installdirs};
    my %mandir      = $pkgdesc->mandirs;

    return << "END_PERL_MB_OPT";
--installdirs $installdirs
--config install${installdirs}man1dir=$mandir{1}
--config install${installdirs}man3dir=$mandir{3}
END_PERL_MB_OPT
}

sub _fake_install {
    my ( $dist, $param_ref ) = @_;

    my $status  = $dist->status;
    my $module  = $dist->parent;
    my $pkgdesc = $status->_pkgdesc;

    my $verbose = $param_ref->{verbose};

    my $wrksrc = $module->status->extract;
    if ( !$wrksrc ) {
        error( loc(q{No dir found to operate on!}) );
        return;
    }

    my $destdir = $pkgdesc->destdir;

    my $cmd;
    my $installer_type = $module->status->installer_type;
    if ( $installer_type eq 'CPANPLUS::Dist::MM' ) {
        my $make = $param_ref->{make};
        $cmd = [ $make, 'install', "DESTDIR=$destdir" ];
    }
    elsif ( $installer_type eq 'CPANPLUS::Dist::Build' ) {
        my $perl = $param_ref->{perl};
        $cmd = [
            $perl, '-MCPANPLUS::Internals::Utils::Autoflush',
            'Build', 'install', '--destdir', $destdir,
            split( ' ', $dist->_perl_mb_opt )
        ];
    }
    else {
        error( loc( q{Unknown type '%1'}, $installer_type ) );
        return;
    }

    msg( loc( q{Staging distribution in '%1'}, $destdir ) );

    return run( $cmd, { dir => $wrksrc, verbose => $verbose } );
}

sub _makepkg {
    my ( $dist, $param_ref ) = @_;

    my $status  = $dist->status;
    my $module  = $dist->parent;
    my $cb      = $module->parent;
    my $conf    = $cb->configure_object;
    my $pkgdesc = $status->_pkgdesc;

    my $verbose    = $param_ref->{verbose};
    my $destdir    = $pkgdesc->destdir;
    my $outputname = $pkgdesc->outputname;

    my $needs_chown = 0;
    my $cmd = [ '/sbin/makepkg', '-l', 'y', '-c', 'y', $outputname ];
    if ( $EFFECTIVE_USER_ID > 0 ) {
        my $fakeroot = $status->_fakeroot_cmd;
        if ($fakeroot) {
            unshift @{$cmd}, $fakeroot;
        }
        else {
            my $sudo = $conf->get_program('sudo');
            if ($sudo) {
                unshift @{$cmd}, $sudo;
                $needs_chown = 1;
            }
            else {
                error( loc($NONROOT_WARNING) );
                return;
            }
        }
    }

    msg( loc( q{Creating package '%1'}, $outputname ) );

    my $orig_uid = $UID;
    my $orig_gid = ( split /\s+/, $GID )[0];
    if ($needs_chown) {
        my @stat = stat($destdir);
        if ( !@stat ) {
            error( loc( q{Could not stat '%1': %2}, $destdir, $OS_ERROR ) );
            return;
        }
        $orig_uid = $stat[4];
        $orig_gid = $stat[5];

        $dist->_chown_recursively( 0, 0, $destdir ) or return;
    }

    my $fail = 0;
    if ( !run( $cmd, { dir => $destdir, verbose => $verbose } ) ) {
        ++$fail;
    }

    if ($needs_chown) {
        if ( -d $destdir ) {
            if (!$dist->_chown_recursively( $orig_uid, $orig_gid, $destdir ) )
            {
                ++$fail;
            }
        }
        if ( -f $outputname ) {
            if (!$dist->_chown_recursively(
                    $orig_uid, $orig_gid, $outputname
                )
                )
            {
                ++$fail;
            }
        }
    }

    if ( !$param_ref->{keep_source} ) {

        # Keep the staging directory if something failed.
        if ( !$fail ) {
            msg( loc( q{Removing '%1'}, $destdir ) );
            if ( !$cb->_rmdir( dir => $destdir ) ) {
                ++$fail;
            }
        }
    }

    return ( $fail ? 0 : 1 );
}

sub _installpkg {
    my ( $dist, $param_ref ) = @_;

    my $status  = $dist->status;
    my $module  = $dist->parent;
    my $cb      = $module->parent;
    my $conf    = $cb->configure_object;
    my $pkgdesc = $status->_pkgdesc;

    my $verbose    = $param_ref->{verbose};
    my $outputname = $pkgdesc->outputname;

    my $cmd
        = [ '/sbin/upgradepkg', '--install-new', '--reinstall', $outputname ];
    if ( $EFFECTIVE_USER_ID > 0 ) {
        my $sudo = $conf->get_program('sudo');
        if ($sudo) {
            unshift @{$cmd}, $sudo;
        }
        else {
            error( loc($NONROOT_WARNING) );
            return;
        }
    }

    msg( loc( q{Installing package '%1'}, $outputname ) );

    return run( $cmd, { verbose => $verbose } );
}

sub _compress_manual_pages {
    my ( $dist, $param_ref ) = @_;

    my $status  = $dist->status;
    my $pkgdesc = $status->_pkgdesc;

    my %mandir = $pkgdesc->mandirs;
    my @mandirs = grep { -d $_ }
        map { catdir( $pkgdesc->destdir, $_ ) } values %mandir;

    my $fail   = 0;
    my $wanted = sub {
        my $filename = $_;
        if ( $filename !~ /\.gz$/ && ( -f $filename || -l $filename ) ) {
            if ( !( gzip($filename) && unlink $filename ) ) {
                error( loc( q{Could not compress file '%1'}, $filename ) );
                ++$fail;
            }
        }
    };
    if (@mandirs) {
        File::Find::find( $wanted, @mandirs );
    }

    return ( $fail ? 0 : 1 );
}

sub _install_docfiles {
    my ( $dist, $param_ref ) = @_;

    my $status  = $dist->status;
    my $module  = $dist->parent;
    my $cb      = $module->parent;
    my $pkgdesc = $status->_pkgdesc;

    my $wrksrc = $module->status->extract;
    if ( !$wrksrc ) {
        error( loc(q{No dir found to operate on!}) );
        return;
    }

    my @docfiles = $pkgdesc->docfiles;

    my $docdir = catdir( $pkgdesc->destdir, $pkgdesc->docdir );
    $cb->_mkdir( dir => $docdir ) or return;

    # Create README.SLACKWARE.
    my $readme = $pkgdesc->readme_slackware;
    my $readmefile = catfile( $docdir, 'README.SLACKWARE' );
    spurt( $readmefile, $readme ) or return;

    # Create perl-Some-Module.SlackBuild.
    my $script = $pkgdesc->build_script;
    my $scriptfile
        = catfile( $docdir, $pkgdesc->normalized_name . '.SlackBuild' );
    spurt( $scriptfile, $script ) or return;

    # Copy files like README and Changes.
    my $fail = 0;
    for my $docfile (@docfiles) {
        my $from = catfile( $wrksrc, $docfile );
        if ( !$cb->_copy( file => $from, to => $docdir ) ) {
            ++$fail;
        }
    }

    return ( $fail ? 0 : 1 );
}

sub _process_packlist {
    my ( $dist, $filename ) = @_;

    my $status  = $dist->status;
    my $pkgdesc = $status->_pkgdesc;

    my $destdir = $pkgdesc->destdir;

    my ($old_pl) = ExtUtils::Packlist->new($filename);
    my @keys = grep {m{^\Q$destdir\E}xms} keys %{$old_pl};
    if ( !@keys ) {
        @keys = keys %{$old_pl};
    }
    if (@keys) {
        my ($new_pl) = ExtUtils::Packlist->new();
        for my $key (@keys) {
            my $value = $old_pl->{$key};
            $key =~ s{^\Q$destdir\E}{}xms;

            # Add .gz to manual pages.
            if ( $key =~ m{/man/man}xms ) {
                if ( $key !~ m{\.gz$}xms ) {
                    $key .= '.gz';
                }
                if ( ref $value eq 'HASH' ) {
                    if (   defined $value->{type}
                        && $value->{type} eq 'link'
                        && defined $value->{from} )
                    {
                        my $from = $value->{from};
                        if ( $from =~ m{/man/man}xms ) {
                            if ( $from !~ m{\.gz$}xms ) {
                                $from .= '.gz';
                                $value->{from} = $from;
                            }
                        }
                    }
                }
            }

            if ( -e "$destdir$key" ) {
                $new_pl->{$key} = $value;
            }
        }
        $new_pl->write($filename);
    }
    return 1;
}

sub _process_installed_files {
    my ( $dist, $param_ref ) = @_;

    my $status  = $dist->status;
    my $module  = $dist->parent;
    my $cb      = $module->parent;
    my $pkgdesc = $status->_pkgdesc;

    my $destdir = $pkgdesc->destdir;

    my $orig_dir = Cwd::cwd();
    if ( !$cb->_chdir( dir => $destdir ) ) {
        return;
    }

    my $fail = 0;
    my @packlists;
    my $wanted = sub {
        my $filename = $_;

        return if $filename eq q{.};

        my @stat = lstat($filename);
        if ( !@stat ) {
            error( loc( q{Could not lstat '%1': %2}, $filename, $OS_ERROR ) );
            return;
        }

        # Skip symbolic links.
        return if -l _;

        # Sanitize the file modes.
        my $perm = ( $stat[2] & oct '0755' ) | oct '0200';
        if ( !chmod $perm, $filename ) {
            error( loc( q{Could not chmod '%1': %2}, $filename, $OS_ERROR ) );
            ++$fail;
        }

        if ( -d $filename ) {

            # Remove empty directories.
            rmdir $filename;
        }
        elsif ( -f $filename ) {
            if ( $filename eq 'perllocal.pod'
                || ( $filename =~ /\.bs$/ && -z $filename ) )
            {
                if ( !unlink $filename ) {
                    error(
                        loc(q{Could not unlink '%1': %2}, $filename,
                            $OS_ERROR
                        )
                    );
                    ++$fail;
                }
            }
            elsif ( $filename eq '.packlist' ) {
                push @packlists, $File::Find::name;
            }
            else {
                my $type = filetype($filename);
                if ( $type =~ /ELF.+(?:executable|shared object)/s ) {
                    if ( !strip($filename) ) {
                        ++$fail;
                    }
                }
            }
        }
    };
    File::Find::finddepth( $wanted, q{.} );

    for my $packlist (@packlists) {
        if ( !$dist->_process_packlist($packlist) ) {
            ++$fail;
        }
    }

    if ( !$cb->_chdir( dir => $orig_dir ) ) {
        ++$fail;
    }

    return ( $fail ? 0 : 1 );
}

sub _make_installdir {
    my ( $dist, $param_ref ) = @_;

    my $status  = $dist->status;
    my $module  = $dist->parent;
    my $cb      = $module->parent;
    my $pkgdesc = $status->_pkgdesc;

    my $installdir = catdir( $pkgdesc->destdir, 'install' );
    return $cb->_mkdir( dir => $installdir );
}

sub _write_config_files {
    my ( $dist, $param_ref ) = @_;

    my $status  = $dist->status;
    my $module  = $dist->parent;
    my $cb      = $module->parent;
    my $pkgdesc = $status->_pkgdesc;

    my $destdir = $pkgdesc->destdir;

    return 1 if !-d catdir( $destdir, 'etc' );

    my $orig_dir = Cwd::cwd();
    if ( !$cb->_chdir( dir => $destdir ) ) {
        return;
    }

    # Find and rename the configuration files.
    my $fail = 0;
    my @conffiles;
    my $wanted = sub {
        my $filename = $_;

        # Skip files that have already been renamed.
        return if $filename =~ /\.new$/;

        if ( -l $filename || -f $filename ) {
            if ( !$cb->_move( file => $filename, to => "$filename.new" ) ) {
                ++$fail;
            }
            push @conffiles, $filename;
        }
    };
    File::Find::find( { wanted => $wanted, no_chdir => 1 }, 'etc' );

    if ( !$cb->_chdir( dir => $orig_dir ) ) {
        ++$fail;
    }

    return   if $fail;
    return 1 if !@conffiles;

    @conffiles = sort { uc $a cmp uc $b } @conffiles;

    # List the configuration files in README.SLACKWARE.
    $dist->_append_config_files_to_readme_slackware(@conffiles) or return;

    # Add a config function to doinst.sh.
    my $script = $pkgdesc->config_function;
    for my $conffile (@conffiles) {
        $conffile =~ s/('+)/'"$1"'/g;    # Quote single quotes.
        $script .= "config '$conffile.new'\n";
    }

    my $installdir = catdir( $pkgdesc->destdir, 'install' );
    my $doinstfile = catfile( $installdir, 'doinst.sh' );
    return spurt( $doinstfile, { append => 1 }, $script );
}

sub _append_config_files_to_readme_slackware {
    my ( $dist, @conffiles ) = @_;

    my $status  = $dist->status;
    my $pkgdesc = $status->_pkgdesc;

    my $readme
        = "\n"
        . "Configuration files\n"
        . "-------------------\n\n"
        . "This package provides the following configuration files:\n\n"
        . join( "\n", map {"* /$_"} @conffiles ) . "\n";

    my $docdir = catdir( $pkgdesc->destdir, $pkgdesc->docdir );
    my $readmefile = catfile( $docdir, 'README.SLACKWARE' );
    return spurt( $readmefile, { append => 1 }, $readme );
}

sub _write_slack_desc {
    my ( $dist, $param_ref ) = @_;

    my $status  = $dist->status;
    my $module  = $dist->parent;
    my $cb      = $module->parent;
    my $pkgdesc = $status->_pkgdesc;

    my $installdir = catdir( $pkgdesc->destdir, 'install' );
    my $descfile = catfile( $installdir, 'slack-desc' );
    my $desc = $pkgdesc->slack_desc;
    return spurt( $descfile, $desc );
}

sub _chown_recursively {
    my ( $dist, $uid, $gid, @filenames ) = @_;

    my $module = $dist->parent;
    my $cb     = $module->parent;
    my $conf   = $cb->configure_object;

    my $cmd = [ '/bin/chown', '-R', "$uid:$gid", @filenames ];
    if ( $EFFECTIVE_USER_ID > 0 ) {
        my $sudo = $conf->get_program('sudo');
        if ($sudo) {
            unshift @{$cmd}, $sudo;
        }
        else {
            error( loc($NONROOT_WARNING) );
            return;
        }
    }
    return run($cmd);
}

1;
__END__