File Coverage

blib/lib/CPANPLUS/Dist/Slackware/Util.pm

Criterion	Covered	Total	%
statement	77	110	70.0
branch	21	52	40.3
condition			n/a
subroutine	15	16	93.7
pod	6	6	100.0
total	119	184	64.6

package CPANPLUS::Dist::Slackware::Util;

use strict;
use warnings;

our $VERSION = '1.029';

use base qw(Exporter);

our @EXPORT_OK
    = qw(can_run run catdir catfile tmpdir slurp spurt filetype gzip strip);

use English qw( -no_match_vars );

use CPANPLUS::Error;

use Cwd qw();
use File::Spec::Functions qw(catdir catfile tmpdir);
use IO::Compress::Gzip qw();
use IPC::Cmd qw(can_run);
use Locale::Maketext::Simple ( Style => 'gettext' );

my $file_cmd  = can_run('file');
my $strip_cmd = can_run('strip');

sub run {
    my ( $cmd, $param_ref ) = @_;

    my $dir     = $param_ref->{dir};
    my $verbose = $param_ref->{verbose};
    my $buf_ref = $param_ref->{buffer};
    if ( !$buf_ref ) {
        my $buf;
        $buf_ref = \$buf;
    }

    my $orig_dir;
    if ($dir) {
        $orig_dir = Cwd::cwd();
        if ( !chdir($dir) ) {
            return;
        }
    }

    my $fail = 0;
    if (!IPC::Cmd::run(
            command => $cmd,
            buffer  => $buf_ref,
            verbose => $verbose
        )
        )
    {
        my $cmdline = join q{ }, @{$cmd};
        error( loc( q{Could not run '%1': %2}, $cmdline, ${$buf_ref} ) );
        ++$fail;
    }

    if ($orig_dir) {
        if ( !chdir($orig_dir) ) {
            ++$fail;
        }
    }

    return ( $fail ? 0 : 1 );
}

sub slurp {
    my $filename = shift;

    my $fh;
    if ( !open $fh, '<', $filename ) {
        error( loc( q{Could not open file '%1': %2}, $filename, $OS_ERROR ) );
        return;
    }

    my $text = do { local $RS = undef; <$fh> };

    if ( !close $fh ) {
        error(
            loc( q{Could not close file '%1': %2}, $filename, $OS_ERROR ) );
        return;
    }

    return $text;
}

sub spurt {
    my ( $filename, @lines ) = @_;

    my $param_ref = ( ref $lines[0] eq 'HASH' ) ? shift @lines : {};
    my $mode      = ( $param_ref->{append} )    ? '>>'         : '>';
    my $binmode   = $param_ref->{binmode};

    my $fh;
    if ( !open $fh, $mode, $filename ) {
        error(
            loc( q{Could not create file '%1': %2}, $filename, $OS_ERROR ) );
        return;
    }

    if ($binmode) {
        if ( !binmode $fh, $binmode ) {
            error(
                loc(q{Could not set binmode for file '%1' to '%2': %3},
                    $filename, $binmode, $OS_ERROR
                )
            );
            return;
        }
    }

    my $fail = 0;
    if ( !print {$fh} @lines ) {
        error(
            loc( q{Could not write to file '%1': %2}, $filename, $OS_ERROR )
        );
        ++$fail;
    }

    if ( !close $fh ) {
        error(
            loc( q{Could not close file '%1': %2}, $filename, $OS_ERROR ) );
        ++$fail;
    }

    return ( $fail ? 0 : 1 );
}

sub filetype {
    my $filename = shift;

    my $type;
    if ($file_cmd) {
        my $cmd = [ $file_cmd, '-b', $filename ];
        if ( !run( $cmd, { buffer => \$type } ) ) {
            undef $type;
        }
    }
    if ($type) {
        chomp $type;
    }
    else {
        $type = 'data';
    }
    return $type;
}

sub gzip {
    my $filename = shift;

    my $gzname = "$filename.gz";
    if ( -l $filename ) {
        my $target = readlink $filename;
        if ($target) {
            if ( symlink "$target.gz", $gzname ) {
                return $gzname;
            }
        }
    }
    elsif ( -f $filename ) {
        if ( IO::Compress::Gzip::gzip( $filename, $gzname ) ) {
            return $gzname;
        }
    }
    return;
}

sub strip {
    my (@filenames) = @_;

    return 1 if !$strip_cmd;

    my $cmd = [ $strip_cmd, '--strip-unneeded', @filenames ];
    return run($cmd);
}

1;
__END__