Perl 5.42 is released: See what's new Learn more

use Pcore;
use Pcore::Lib::Scalar qw[is_glob is_plain_arrayref is_plain_hashref];
use Fcntl qw[:DEFAULT];
use Cwd qw[]; ## no critic qw[Modules::ProhibitEvilModules]
use Config;
sub cat_path {
return P->path( join '/', splice @_, 1 );
}
# return cwd, symlinks are resolved
sub cwd { return P->path->to_abs }
sub chdir ($path) { ## no critic qw[Subroutines::ProhibitBuiltinHomonyms]
if ( defined wantarray ) {
my $cwd = cwd->to_string;
return unless chdir $path;
return Pcore::Lib::File::ChdirGuard->new( { dir => $cwd } );
}
elsif ( chdir $path ) {
return;
}
else {
die qq[Can't chdir to "$path"];
}
}
# change umask and return old umask
sub umask ($mode) { ## no critic qw[Subroutines::ProhibitBuiltinHomonyms]
return '00' if $MSWIN;
if ( defined wantarray ) {
return Pcore::Lib::File::UmaskGuard->new( { old_umask => CORE::umask calc_umask($mode) } );
}
else {
return CORE::umask calc_umask($mode);
}
}
sub calc_umask ( $mode, % ) {
return unless defined $mode;
my %args = (
oct => 0,
splice @_, 1,
);
if ( $mode =~ /[^[:digit:]]/smi ) {
state $mode_cache = {};
if ( !exists $mode_cache->{$mode} ) {
my $mode_val = 0b111_111_111; # all perms are disabled by default
my @mode = map {lc} split //sm, $mode;
# user
$mode_val &= 0b011_111_111 if defined $mode[0] && $mode[0] eq q[r];
$mode_val &= 0b101_111_111 if defined $mode[1] && $mode[1] eq q[w];
$mode_val &= 0b110_111_111 if defined $mode[2] && $mode[2] eq q[x];
# group
$mode_val &= 0b111_011_111 if defined $mode[3] && $mode[3] eq q[r];
$mode_val &= 0b111_101_111 if defined $mode[4] && $mode[4] eq q[w];
$mode_val &= 0b111_110_111 if defined $mode[5] && $mode[5] eq q[x];
# other
$mode_val &= 0b111_111_011 if defined $mode[6] && $mode[6] eq q[r];
$mode_val &= 0b111_111_101 if defined $mode[7] && $mode[7] eq q[w];
$mode_val &= 0b111_111_110 if defined $mode[8] && $mode[8] eq q[x];
$mode_cache->{$mode} = $mode_val;
}
$mode = $mode_cache->{$mode};
}
else {
$mode = oct $mode if substr( $mode, 0, 1 ) eq '0';
}
return $args{oct} ? sprintf '0%o', $mode : $mode;
}
# mkdir with chmod support
sub mkdir ( $path, $mode = undef ) { ## no critic qw[Subroutines::ProhibitBuiltinHomonyms]
if ( defined wantarray ) {
if ( defined $mode ) {
return mkdir $path, calc_chmod($mode);
}
else {
return mkdir $path;
}
}
else {
if ( defined $mode ) {
mkdir $path, calc_chmod($mode) or die qq[Can't mkdir "$path". $!];
}
else {
mkdir $path or die qq[Can't mkdir "$path". $!];
}
return;
}
}
sub chmod ( $mode, @path ) { ## no critic qw[Subroutines::ProhibitBuiltinHomonyms]
if ( defined wantarray ) {
return CORE::chmod calc_chmod($mode), @path;
}
else {
return CORE::chmod( calc_chmod($mode), @path ) || die qq[$! during chmod $mode, ] . join q[, ], @path;
}
}
sub calc_chmod ( $mode, % ) {
return unless defined $mode;
my %args = (
oct => 0,
splice @_, 1,
);
if ( $mode =~ /[^[:digit:]]/smi ) {
state $mode_cache = {};
if ( !exists $mode_cache->{$mode} ) {
my $mode_val = 0; # all perms are disabled by default
my @mode = map {lc} split //sm, $mode;
# user
$mode_val |= 0b100_000_000 if defined $mode[0] && $mode[0] eq q[r];
$mode_val |= 0b010_000_000 if defined $mode[1] && $mode[1] eq q[w];
$mode_val |= 0b001_000_000 if defined $mode[2] && $mode[2] eq q[x];
# group
$mode_val |= 0b000_100_000 if defined $mode[3] && $mode[3] eq q[r];
$mode_val |= 0b000_010_000 if defined $mode[4] && $mode[4] eq q[w];
$mode_val |= 0b000_001_000 if defined $mode[5] && $mode[5] eq q[x];
# other
$mode_val |= 0b000_000_100 if defined $mode[6] && $mode[6] eq q[r];
$mode_val |= 0b000_000_010 if defined $mode[7] && $mode[7] eq q[w];
$mode_val |= 0b000_000_001 if defined $mode[8] && $mode[8] eq q[x];
$mode_cache->{$mode} = $mode_val;
}
$mode = $mode_cache->{$mode};
}
else {
$mode = oct $mode if substr( $mode, 0, 1 ) eq '0';
}
return $args{oct} ? sprintf '0%o', $mode : $mode;
}
# READ / WRITE
sub read_bin ( $path, % ) {
my %args = (
cb => undef,
buf_size => 1_048_576,
splice @_, 1,
);
my $fh = get_fh( $path, O_RDONLY, crlf => 0 );
my $tail = $EMPTY;
READ:
my $bytes = read $fh, my $buf, $args{buf_size};
die qq[Couldn't read file "$path": $!] if !defined $bytes;
if ( $args{cb} ) {
if ($bytes) {
return if !$args{cb}->( \$buf );
goto READ;
}
else {
$args{cb}->(undef);
return;
}
}
else {
if ($bytes) {
$tail .= $buf;
goto READ;
}
else {
return $tail;
}
}
}
sub read_text ( $path, % ) {
my %args = (
crlf => 1, # undef - auto, 1 - on, 0 - off (for binary files)
binmode => ':encoding(UTF-8)',
cb => undef,
buf_size => 1_048_576,
splice @_, 1,
);
my $fh = get_fh( $path, O_RDONLY, crlf => $args{crlf}, binmode => $args{binmode} );
my $tail = $EMPTY;
READ:
my $bytes = read $fh, my $buf, $args{buf_size};
die qq[Couldn't read file "$path": $!] if !defined $bytes;
if ( $args{cb} ) {
if ($bytes) {
return if !$args{cb}->( \$buf );
goto READ;
}
else {
$args{cb}->(undef);
return;
}
}
else {
if ($bytes) {
$tail .= $buf;
goto READ;
}
else {
return $tail;
}
}
}
sub read_lines ( $path, % ) {
my %args = (
crlf => 1, # undef - auto, 1 - on, 0 - off (for binary files)
binmode => ':encoding(UTF-8)',
cb => undef,
buf_size => 1_048_576,
empty_lines => 0, # only for array_ref mode, don't skip empty lines
splice @_, 1,
);
my $fh = get_fh( $path, O_RDONLY, crlf => $args{crlf}, binmode => $args{binmode} );
my $tail = $EMPTY;
READ:
my $bytes = read $fh, my $buf, $args{buf_size};
die qq[Couldn't read file "$path": $!] if !defined $bytes;
if ( $args{cb} ) {
if ($bytes) {
if ( index( $buf, qq[\n] ) == -1 ) { # buf doesn't contains strings
$tail .= $buf;
}
else { # buf contains strings
$buf = $tail . $buf;
if ( $args{empty_lines} ) {
my $array_ref = [ split /\n/sm, $buf, -1 ];
$tail = pop $array_ref->@*;
return if !$args{cb}->($array_ref);
}
else {
my $array_ref = [ split /\n+/sm, $buf ];
# remove leading $EMPTY, preserved by split
shift $array_ref->@* if defined $array_ref->[0] && $array_ref->[0] eq $EMPTY;
if ( substr( $buf, -1, 1 ) ne qq[\n] ) {
$tail = pop $array_ref->@*;
}
else {
$tail = $EMPTY;
}
if ( $array_ref->@* ) {
return if !$args{cb}->($array_ref);
}
}
}
goto READ;
}
else {
if ( $tail ne $EMPTY ) {
return if !$args{cb}->( [$tail] );
}
$args{cb}->(undef);
return;
}
}
else {
if ($bytes) {
$tail .= $buf;
goto READ;
}
else {
if ( $args{empty_lines} ) {
my $array_ref = [ split /\n/sm, $tail, -1 ];
# remove trailing $EMPTY, preserved by split
pop $array_ref->@* if defined $array_ref->[-1] && $array_ref->[-1] eq $EMPTY;
return $array_ref;
}
else {
my $array_ref = [ split /\n+/sm, $tail ];
# remove leading $EMPTY, preserved by split
shift $array_ref->@* if defined $array_ref->[0] && $array_ref->[0] eq $EMPTY;
return $array_ref;
}
}
}
}
sub write_bin {
my $path = shift;
my %args = (
mode => 'rw-------',
umask => undef,
autoflush => 1,
( is_plain_hashref $_[0] ? %{ shift @_ } : () ),
);
_write_to_fh( get_fh( $path, O_WRONLY | O_CREAT | O_TRUNC, %args, crlf => 0 ), @_ );
return;
}
sub append_bin {
my $path = shift;
my %args = (
mode => 'rw-------',
umask => undef,
autoflush => 1,
( is_plain_hashref $_[0] ? %{ shift @_ } : () ),
);
_write_to_fh( get_fh( $path, O_WRONLY | O_CREAT | O_APPEND, %args, crlf => 0 ), @_ );
return;
}
sub write_text {
my $path = shift;
my %args = (
crlf => undef, # undef - auto, 1 - on, 0 - off (for binary files)
binmode => ':encoding(UTF-8)',
autoflush => 1,
mode => 'rw-------',
umask => undef,
( is_plain_hashref $_[0] ? %{ shift @_ } : () ),
);
_write_to_fh( get_fh( $path, O_WRONLY | O_CREAT | O_TRUNC, %args ), @_ );
return;
}
sub append_text {
my $path = shift;
my %args = (
crlf => undef, # undef - auto, 1 - on, 0 - off (for binary files)
binmode => ':encoding(UTF-8)',
autoflush => 1,
mode => 'rw-------',
umask => undef,
( is_plain_hashref $_[0] ? %{ shift @_ } : () ),
);
_write_to_fh( get_fh( $path, O_WRONLY | O_CREAT | O_APPEND, %args ), @_ );
return;
}
sub encode_path ($path) {
if ($MSWIN) {
state $enc = Encode::find_encoding($Pcore::WIN_ENC);
return $enc->encode( $path, Encode::FB_CROAK ) if utf8::is_utf8($path);
}
return $path;
}
sub get_fh ( $path, $mode, @ ) {
my %args = (
mode => 'rw-------',
umask => undef,
crlf => 0, # undef - auto, 1 - on, 0 - off (for binary files)
binmode => undef,
autoflush => 1,
splice @_, 2,
);
if ( is_glob $path ) {
return $path;
}
else {
my $umask_guard;
$umask_guard = &umask( $args{umask} ) if defined $args{umask}; ## no critic qw[Subroutines::ProhibitAmpersandSigils]
# encode filename to native OS encoding
$path = encode_path($path);
sysopen my $fh, $path, $mode, calc_chmod( $args{mode} ) or die qq[Can't open file "$path"];
my $binmode = $EMPTY;
$args{crlf} //= $MSWIN ? 1 : 0;
if ( $args{crlf} ) {
$binmode = ':crlf' if !$MSWIN;
}
else {
$binmode = ':raw' if $MSWIN;
}
$binmode .= $args{binmode} if $args{binmode};
binmode $fh, $binmode or die qq[Can't set binmode file "$path"] if $binmode;
$fh->autoflush(1) if $args{autoflush};
return $fh;
}
}
sub _write_to_fh {
my $fh = shift;
for my $str (@_) {
if ( is_plain_arrayref $str ) {
for my $line ( $str->@* ) {
print {$fh} $line, qq[\n];
}
}
elsif ( ref $str eq 'SCALAR' ) {
print {$fh} $str->$*;
}
else {
print {$fh} $str;
}
}
return;
}
# READ DIR
sub read_dir ( $path, % ) {
my %args = (
keep_dot => 0,
full_path => 0,
splice @_, 1,
);
opendir my $dh, $path or die qq[Can't open dir "$path"];
my $files;
if ( $args{keep_dot} ) {
$files = [ readdir $dh ];
}
else {
$files = [ grep { $_ ne q[.] && $_ ne q[..] } readdir $dh ];
}
if ( $args{full_path} ) {
my $path = P->path($path);
$files = [ map {"$path/$_"} $files->@* ];
}
closedir $dh or die;
return $files;
}
# TOUCH
sub touch ( $path, % ) {
my %args = (
atime => undef,
mtime => undef,
mode => q[rw-------],
umask => undef,
splice @_, 1,
);
$path = encode_path($path);
if ( !-e $path ) {
# set umask if defined
my $umask_guard = defined $args{umask} ? &umask( $args{umask} ) : undef; ## no critic qw[Subroutines::ProhibitAmpersandSigils]
sysopen my $FH, $path, Fcntl::O_WRONLY | Fcntl::O_CREAT | Fcntl::O_APPEND, calc_chmod( $args{mode} ) or die qq[Can't touch file "$path"];
close $FH or die;
}
# set utime
$args{atime} //= $args{mtime} // time;
$args{mtime} //= $args{atime};
utime $args{atime}, $args{mtime}, $path or die;
return;
}
# MKPATH, RMTREE, EMPTY_DIR
sub mkpath ( $path, % ) {
my %args = (
mode => q[rwx------],
umask => undef,
splice @_, 1,
);
require File::Path; ## no critic qw[Modules::ProhibitEvilModules]
$args{mode} = calc_chmod( $args{mode} );
my $umask_guard = defined $args{umask} ? &umask( delete $args{umask} ) : delete $args{umask}; ## no critic qw[Subroutines::ProhibitAmpersandSigils]
return File::Path::make_path( "$path", \%args );
}
sub rmtree ( $path, @ ) {
my %args = (
safe => 0, # 0 - will attempts to alter file permission
keep_root => 0,
splice @_, 1,
);
require File::Path; ## no critic qw[Modules::ProhibitEvilModules]
my $error;
$args{error} = \$error;
my $removed = File::Path::remove_tree( "$path", \%args );
return $error->@* ? () : 1;
}
sub empty_dir ( $path, @ ) {
my %args = (
safe => 0, # 0 - will attempts to alter file permission
splice @_, 1,
keep_root => 1,
);
require File::Path; ## no critic qw[Modules::ProhibitEvilModules]
return File::Path::remove_tree( "$path", \%args );
}
# TEMP
sub tempfile (%args) {
return Pcore::Lib::File::TempFile->new(%args);
}
sub tempdir (%args) {
return Pcore::Lib::File::TempDir->new( \%args );
}
sub temppath {
my %args = (
base => $ENV->{TEMP_DIR},
suffix => $EMPTY,
tmpl => 'temp-' . $$ . '-XXXXXXXX',
@_,
);
$args{suffix} = q[.] . $args{suffix} if defined $args{suffix} && $args{suffix} ne $EMPTY && substr( $args{suffix}, 0, 1 ) ne q[.];
mkpath( $args{base} ) if !-e $args{base};
my $attempt = 3;
REDO:
die q[Can't create temporary path] if !$attempt--;
my $filename = $args{tmpl} =~ s/X/$Pcore::Lib::File::TempFile::TMPL->[rand $Pcore::Lib::File::TempFile::TMPL->@*]/smger . $args{suffix};
goto REDO if -e $args{base} . q[/] . $filename;
return P->path("$args{base}/$filename");
}
# COPY / MOVE FILE
sub copy ( $from, $to, @ ) {
my %args = (
glob => undef,
dir_mode => q[rwxr-xr-x],
umask => undef,
buf_size => undef,
copy_link => 0, # if 1 - symlinks will be copied as symlinks
rm_file => 1, # remove target file before copying, 0 - off, 1 - die if can't remove, 2 - return if can't remove
rm_dir => 1, # remove target dir before copying, 0 - off, 1 - die if can't remove, 2 - return if can't remove
pfs_check => 1,
cprf => 1, # only if $to is dir, if $to/ is exists put $from/ content into $to/ instead of replace $to/ with $from/
splice @_, 2,
);
my $umask_guard = defined $args{umask} ? &umask( $args{umask} ) : undef; ## no critic qw[Subroutines::ProhibitAmpersandSigils]
local $File::Copy::Recursive::DirPerms = calc_chmod( $args{dir_mode}, oct => 1 );
local $File::Copy::Recursive::CopyLink = $args{copy_link};
local $File::Copy::Recursive::RMTrgFil = $args{rm_file};
local $File::Copy::Recursive::RMTrgDir = $args{rm_dir};
local $File::Copy::Recursive::PFSCheck = $args{pfs_check};
local $File::Copy::Recursive::CPRFComp = $args{cprf};
state $init = do {
# redefine $Coro::State::DIEHOOK, required under MSWin to handle Time::HiRes::utime import
local $SIG{__DIE__} = undef;
};
if ( -d $from ) {
if ( $args{glob} ) {
return File::Copy::Recursive::rcopy_glob( qq[$from/$args{glob}], $to, $args{buf_size} // () );
}
else {
return File::Copy::Recursive::dircopy( $from, $to, $args{buf_size} // () );
}
}
elsif ( -f $from ) {
return File::Copy::Recursive::fcopy( $from, $to, $args{buf_size} // () );
}
else {
die qq[Source "$from" not exists];
}
}
sub move ( $from, $to, @ ) {
my %args = (
dir_mode => q[rwxr-xr-x],
umask => undef,
buf_size => undef,
copy_link => 0, # if 1 - symlinks will be copied as symlinks
rm_file => 1, # remove target file before copying, 0 - off, 1 - die if can't remove, 2 - return if can't remove
rm_dir => 1, # remove target dir before copying, 0 - off, 1 - die if can't remove, 2 - return if can't remove
pfs_check => 1,
cprf => 1, # only if $to is dir, if $to/ is exists put $from/ content into $to/ instead of replace $to/ with $from/
splice @_, 2,
);
my $umask_guard = defined $args{umask} ? &umask( $args{umask} ) : undef; ## no critic qw[Subroutines::ProhibitAmpersandSigils]
local $File::Copy::Recursive::DirPerms = calc_chmod( $args{dir_mode}, oct => 1 );
local $File::Copy::Recursive::CopyLink = $args{copy_link};
local $File::Copy::Recursive::RMTrgFil = $args{rm_file};
local $File::Copy::Recursive::RMTrgDir = $args{rm_dir};
local $File::Copy::Recursive::PFSCheck = $args{pfs_check};
local $File::Copy::Recursive::CPRFComp = $args{cprf};
state $init = do {
# redefine $Coro::State::DIEHOOK, required under MSWin to handle Time::HiRes::utime import
local $SIG{__DIE__} = undef;
};
if ( -d $from ) {
if ( $args{glob} ) {
return File::Copy::Recursive::rmove_glob( qq[$from/$args{glob}], $to, $args{buf_size} // () );
}
else {
return File::Copy::Recursive::dirmove( $from, $to, $args{buf_size} // () );
}
}
elsif ( -f $from ) {
return File::Copy::Recursive::fmove( $from, $to, $args{buf_size} // () );
}
else {
die qq[Source "$from" not exists];
}
return;
}
# WHERE
sub where ( $filename ) {
my $wantarray = wantarray;
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::Lib::File
=head1 SYNOPSIS
=head1 DESCRIPTION
=cut