File Coverage

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

Criterion	Covered	Total	%
statement	123	161	76.4
branch	27	62	43.5
condition	11	20	55.0
subroutine	27	29	93.1
pod	11	11	100.0
total	199	283	70.3

package CPANPLUS::Dist::Debora::Util;

# 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(Exporter);

our @EXPORT_OK = qw(
    parse_version
    module_is_distributed_with_perl
    decode_utf8
    slurp_utf8
    spew_utf8
    can_run
    run
    unix_path
    filetype
    find_most_recent_mtime
    find_shared_objects
    is_testing
);

use Carp qw(croak);
use Cwd qw(cwd);
use Encode qw(decode);
use English qw(-no_match_vars);
use File::Spec::Functions qw(catfile splitdir splitpath);
use File::Spec::Unix qw();
use IPC::Cmd qw(can_run);
use Module::CoreList 2.32;
use version 0.77;

use CPANPLUS::Error qw(error);

# Avoid warnings from IO::Select by using IPC::Run.
$IPC::Cmd::USE_IPC_RUN = IPC::Cmd->can_use_ipc_run;

my $perl_version = parse_version($PERL_VERSION);

sub parse_version {
    my $string = shift;

    return version->parse($string);
}

sub module_is_distributed_with_perl {
    my ($module_name, $version) = @_;

    my $ok = 0;

    # cpan2dist is run with -w, which triggers a warning in Module::CoreList.
    local $WARNING = 0;

    my $upper = Module::CoreList->removed_from($module_name);
    if (!defined $upper || $perl_version < parse_version($upper)) {
        my $lower = Module::CoreList->first_release($module_name, $version);
        if (defined $lower && $perl_version >= parse_version($lower)) {
            $ok = 1;
        }
    }

    return $ok;
}

sub decode_utf8 {
    my $bytes = shift;

    return decode('UTF-8', $bytes);
}

sub slurp_utf8 {
    my $filename = shift;

    my $data;

    my $ok = open my $fh, '<:encoding(UTF-8)', $filename;
    if ($ok) {
        local $RS = undef;
        $data = <$fh>;
        close $fh or $ok = 0;
    }

    return $data;
}

sub spew_utf8 {
    my ($filename, $string) = @_;

    my $ok = open my $fh, '>:encoding(UTF-8)', $filename;
    if ($ok) {
        $ok = print {$fh} $string;
        close $fh or $ok = 0;
    }

    return $ok;
}

sub run {
    my (%options) = @_;

    my $ok = 0;

    my $command = $options{command};
    if (!$command) {
        error('No command');
        return $ok;
    }

    my $dir = $options{dir};
    delete $options{dir};

    if (!exists $options{buffer}) {
        my $buf = q{};
        $options{buffer} = \$buf;
    }

    my $on_error = $options{on_error}
        // sub { error("Could not run '$_[0]': $_[1]") };
    delete $options{on_error};

    my $origdir;
    if ($dir) {
        $origdir = cwd;
        if (!chdir $dir) {
            return $ok;
        }
    }

    $ok = IPC::Cmd::run(%options);
    if (!$ok) {
        my $cmdline = join q{ }, @{$command};
        my $output  = ${$options{buffer}} // q{};
        $on_error->($cmdline, $output);
    }

    if ($origdir) {
        if (!chdir $origdir) {
            $ok = 0;
        }
    }

    return $ok;
}

sub unix_path {
    my $path = shift;

    (undef, $path) = splitpath($path, 1);
    $path = File::Spec::Unix->catfile(splitdir($path));

    return $path;
}

sub filetype {
    my $filename = shift;

    my %type_for = (
        '1'     => 'text',
        '1p'    => 'text',
        '3'     => 'text',
        '3perl' => 'text',
        '3pm'   => 'text',
        'bat'   => 'script',
        'dll'   => 'executable',
        'dylib' => 'executable',
        'exe'   => 'executable',
        'pl'    => 'script',
        'pm'    => 'text',
        'pod'   => 'text',
        'so'    => 'executable',
    );

    my @magic = (
        [0, 4, '7F454C46', 'executable'],    # ELF
        [0, 4, 'FEEDFACE', 'executable'],    # Mach-O
        [0, 4, 'CEFAEDFE', 'executable'],    # Mach-O
        [0, 4, 'FEEDFACF', 'executable'],    # Mach-O
        [0, 4, 'CFFAEDFE', 'executable'],    # Mach-O
        [0, 2, '4D5A',     'executable'],    # PE
        [0, 2, '2321',     'script'],        # Shebang
    );

    my $type = 'data';

    if ($filename =~ m{[.]([^.]+) \z}xms) {
        my $suffix = lc $1;
        if (exists $type_for{$suffix}) {
            $type = $type_for{$suffix};
        }
    }

    if ($type eq 'data') {
        if (open my $fh, '<:raw', $filename) {
            if (read $fh, my $data, 16) {
                TYPE:
                for (@magic) {
                    if (substr($data, $_->[0], $_->[1]) eq pack 'H*', $_->[2]) {
                        $type = $_->[3];
                        last TYPE;
                    }
                }
            }
            close $fh or undef;
        }
    }

    return $type;
}

sub find_most_recent_mtime {
    my $sourcedir = shift;

    my $most_recent_mtime = 0;

    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) {
                __SUB__->($path);
            }
            else {
                my @stat = stat $path;
                if (@stat) {
                    my $mtime = $stat[9];
                    if ($most_recent_mtime < $mtime) {
                        $most_recent_mtime = $mtime;
                    }
                }
            }
        }
        closedir $dh;

        return;
    };
    $find->($sourcedir);

    return $most_recent_mtime;
}

sub find_shared_objects {
    my $stagingdir = shift;

    my @shared_objects;

    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) {
                __SUB__->($path);
            }
            else {
                if (filetype($path) eq 'executable') {
                    push @shared_objects, $path;
                }
            }
        }
        closedir $dh;

        return;
    };
    $find->($stagingdir);

    return \@shared_objects;
}

sub is_testing {
    return $ENV{AUTOMATED_TESTING} || $ENV{RELEASE_TESTING};
}

1;
__END__