view release on metacpan or  search on metacpan

lib/Pcore/Util/File.pm  view on Meta::CPAN

    state $env_path = $EMPTY;

    state $paths;

    if ( $env_path ne $ENV{PATH} ) {
        $env_path = $ENV{PATH};

        $paths = [ q[.], grep {$_} split /$Config{path_sep}/sm, $ENV{PATH} ];
    }

    state $env_pathext = $EMPTY;

    state $pathext = [$EMPTY];

    if ( $MSWIN && $ENV{PATHEXT} && $env_pathext ne $ENV{PATHEXT} ) {
        $env_pathext = $ENV{PATHEXT};

        $pathext = [ $EMPTY, grep {$_} split /$Config{path_sep}/sm, $ENV{PATHEXT} ];
    }

    my @res;

    for my $path ( $paths->@* ) {
        for my $ext ( $pathext->@* ) {
            if ( -e "$path/${filename}${ext}" ) {
                if ($wantarray) {
                    push @res, P->path("$path/${filename}${ext}")->to_abs;
                }
                else {
                    return P->path("$path/${filename}${ext}")->to_abs;
                }
            }
        }
    }

    return @res;
}

# UNTAR
sub untar ( $tar, $target, @ ) {
    require Archive::Tar;

    my %args = (
        strip_component => 0,
        splice @_, 2,
    );

    $tar = Archive::Tar->new($tar);

    my $strip_component;

    my @extracted;

    for my $file ( $tar->get_files ) {
        next if !defined $file->{filename};

        my $path = P->path( '/' . $file->full_path );

        if ( $args{strip_component} ) {
            if ( !$strip_component ) {
                my @labels = split m[/]sm, $path;

                die q[Can't strip component, path is too short] if @labels < $args{strip_component};

                $strip_component = P->path( '/' . join( '/', splice @labels, 0, $args{strip_component} + 1 ) );
            }

            die qq[Can't strip component "$strip_component" from path "$path"] if $path !~ s[\A$strip_component][]sm;
        }

        my $target_path = P->path("$target/$path");

        P->file->mkpath( $target_path->{dirname} ) if !-e $target_path->{dirname};

        if ( $file->extract($target_path) ) {
            push @extracted, $target_path;
        }
        else {
            die qq[Can't extract "$path"];
        }
    }

    return \@extracted;
}

1;
## -----SOURCE FILTER LOG BEGIN-----
##
## PerlCritic profile "pcore-script" policy violations:
## +------+----------------------+----------------------------------------------------------------------------------------------------------------+
## | Sev. | Lines                | Policy                                                                                                         |
## |======+======================+================================================================================================================|
## |    3 |                      | Subroutines::ProhibitExcessComplexity                                                                          |
## |      | 48                   | * Subroutine "calc_umask" with high complexity score (25)                                                      |
## |      | 122                  | * Subroutine "calc_chmod" with high complexity score (25)                                                      |
## |      | 248                  | * Subroutine "read_lines" with high complexity score (27)                                                      |
## |------+----------------------+----------------------------------------------------------------------------------------------------------------|
## |    1 | 784                  | CodeLayout::ProhibitParensWithBuiltins - Builtin function called with parentheses                              |
## +------+----------------------+----------------------------------------------------------------------------------------------------------------+
##
## -----SOURCE FILTER LOG END-----
__END__
=pod

=encoding utf8

=head1 NAME

Pcore::Util::File

=head1 SYNOPSIS

=head1 DESCRIPTION

=cut