sub
cat_path {
return
P->path(
join
'/'
,
splice
@_
, 1 );
}
sub
cwd {
return
P->path->to_abs }
sub
chdir
(
$path
) {
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"]
;
}
}
sub
umask
(
$mode
) {
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;
my
@mode
=
map
{
lc
}
split
//sm,
$mode
;
$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]
;
$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]
;
$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
;
}
sub
mkdir
(
$path
,
$mode
=
undef
) {
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
) {
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;
my
@mode
=
map
{
lc
}
split
//sm,
$mode
;
$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]
;
$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]
;
$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
;
}
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,
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,
binmode
=>
':encoding(UTF-8)'
,
cb
=>
undef
,
buf_size
=> 1_048_576,
empty_lines
=> 0,
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 ) {
$tail
.=
$buf
;
}
else
{
$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
];
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 ];
pop
$array_ref
->@*
if
defined
$array_ref
->[-1] &&
$array_ref
->[-1] eq
$EMPTY
;
return
$array_ref
;
}
else
{
my
$array_ref
= [
split
/\n+/sm,
$tail
];
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
,
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
,
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,
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
};
$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
;
}
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
;
}
sub
touch (
$path
, % ) {
my
%args
= (
atime
=>
undef
,
mtime
=>
undef
,
mode
=>
q[rw-------]
,
umask
=>
undef
,
splice
@_
, 1,
);
$path
= encode_path(
$path
);
if
( !-e
$path
) {
my
$umask_guard
=
defined
$args
{
umask
} ?
&umask
(
$args
{
umask
} ) :
undef
;
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
;
}
$args
{atime} //=
$args
{mtime} //
time
;
$args
{mtime} //=
$args
{atime};
utime
$args
{atime},
$args
{mtime},
$path
or
die
;
return
;
}
sub
mkpath (
$path
, % ) {
my
%args
= (
mode
=>
q[rwx------]
,
umask
=>
undef
,
splice
@_
, 1,
);
$args
{mode} = calc_chmod(
$args
{mode} );
my
$umask_guard
=
defined
$args
{
umask
} ?
&umask
(
delete
$args
{
umask
} ) :
delete
$args
{
umask
};
return
File::Path::make_path(
"$path"
, \
%args
);
}
sub
rmtree (
$path
, @ ) {
my
%args
= (
safe
=> 0,
keep_root
=> 0,
splice
@_
, 1,
);
my
$error
;
$args
{error} = \
$error
;
my
$removed
= File::Path::remove_tree(
"$path"
, \
%args
);
return
$error
->@* ? () : 1;
}
sub
empty_dir (
$path
, @ ) {
my
%args
= (
safe
=> 0,
splice
@_
, 1,
keep_root
=> 1,
);
return
File::Path::remove_tree(
"$path"
, \
%args
);
}
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"
);
}
sub
copy (
$from
,
$to
, @ ) {
my
%args
= (
glob
=>
undef
,
dir_mode
=>
q[rwxr-xr-x]
,
umask
=>
undef
,
buf_size
=>
undef
,
copy_link
=> 0,
rm_file
=> 1,
rm_dir
=> 1,
pfs_check
=> 1,
cprf
=> 1,
splice
@_
, 2,
);
my
$umask_guard
=
defined
$args
{
umask
} ?
&umask
(
$args
{
umask
} ) :
undef
;
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
{
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,
rm_file
=> 1,
rm_dir
=> 1,
pfs_check
=> 1,
cprf
=> 1,
splice
@_
, 2,
);
my
$umask_guard
=
defined
$args
{
umask
} ?
&umask
(
$args
{
umask
} ) :
undef
;
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
{
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
;
}
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
;
}
sub
untar (
$tar
,
$target
, @ ) {
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;