use
5.010001;
use
Fcntl
qw( :flock :seek )
;
is_hashref is_member thread_id throw )
;
PositiveInt RegexpRef SimpleStr Str )
;
use
overload
'""'
=>
sub
{
$_
[ 0 ]->pathname },
fallback
=> 1;
our
@EXPORT
=
qw( io )
;
my
@ARG_NAMES
=
qw( name mode perms )
;
my
$IO_LOCK
= enum
'IO_Lock'
=> [ FALSE, LOCK_BLOCKING, LOCK_NONBLOCKING ];
my
$IO_MODE
= enum
'IO_Mode'
=> [
qw( a a+ r r+ w w+ )
];
my
$IO_TYPE
= enum
'IO_Type'
=> [
qw( dir file )
];
my
$LC_OSNAME
=
lc
$OSNAME
;
my
$NTFS
=
$LC_OSNAME
eq EVIL ||
$LC_OSNAME
eq CYGWIN ? TRUE : FALSE;
has
'autoclose'
=>
is
=>
'lazy'
,
isa
=> Bool,
default
=> TRUE ;
has
'have_lock'
=>
is
=>
'rwp'
,
isa
=> Bool,
default
=> FALSE ;
has
'io_handle'
=>
is
=>
'rwp'
,
isa
=> Maybe[Object] ;
has
'is_open'
=>
is
=>
'rwp'
,
isa
=> Bool,
default
=> FALSE ;
has
'mode'
=>
is
=>
'rwp'
,
isa
=>
$IO_MODE
,
default
=>
'r'
;
has
'name'
=>
is
=>
'rwp'
,
isa
=> SimpleStr,
default
=> NUL,
coerce
=> \
&__coerce_name
,
lazy
=> TRUE ;
has
'_perms'
=>
is
=>
'rwp'
,
isa
=> PositiveInt,
default
=> PERMS,
init_arg
=>
'perms'
;
has
'reverse'
=>
is
=>
'lazy'
,
isa
=> Bool,
default
=> FALSE ;
has
'sort'
=>
is
=>
'lazy'
,
isa
=> Bool,
default
=> TRUE ;
has
'type'
=>
is
=>
'rwp'
,
isa
=> Maybe[
$IO_TYPE
] ;
has
'_assert'
=>
is
=>
'rw'
,
isa
=> Bool,
default
=> FALSE ;
has
'_atomic'
=>
is
=>
'rw'
,
isa
=> Bool,
default
=> FALSE ;
has
'_atomic_infix'
=>
is
=>
'rw'
,
isa
=> SimpleStr,
default
=>
'B_*'
;
has
'_backwards'
=>
is
=>
'rw'
,
isa
=> Bool,
default
=> FALSE ;
has
'_block_size'
=>
is
=>
'rw'
,
isa
=> PositiveInt,
default
=> 1024 ;
has
'_chomp'
=>
is
=>
'rw'
,
isa
=> Bool,
default
=> FALSE ;
has
'_deep'
=>
is
=>
'rw'
,
isa
=> Bool,
default
=> FALSE ;
has
'_dir_pattern'
=>
is
=>
'lazy'
,
isa
=> RegexpRef ;
has
'_filter'
=>
is
=>
'rw'
,
isa
=> Maybe[CodeRef] ;
has
'_layers'
=>
is
=>
'ro'
,
isa
=> ArrayRef[SimpleStr],
default
=>
sub
{ [] };
has
'_lock'
=>
is
=>
'rw'
,
isa
=>
$IO_LOCK
,
default
=> FALSE ;
has
'_lock_obj'
=>
is
=>
'rw'
,
isa
=> Maybe[Object],
writer
=>
'lock_obj'
;
has
'_no_follow'
=>
is
=>
'rw'
,
isa
=> Bool,
default
=> FALSE ;
has
'_separator'
=>
is
=>
'rw'
,
isa
=> Str,
default
=>
$RS
;
has
'_umask'
=>
is
=>
'rw'
,
isa
=> ArrayRef[Int],
default
=>
sub
{ [] };
around
'BUILDARGS'
=>
sub
{
my
(
$orig
,
$class
,
@args
) =
@_
;
return
__build_attr_from(
@args
);
};
sub
__build_attr_from {
my
$n
= 0;
$n
++
while
(
defined
$_
[
$n
]);
return
(
$n
== 0 ) ? {}
: __is_one_of_us(
$_
[ 0 ] ) ? __clone_one_of_us(
@_
)
: is_hashref(
$_
[ 0 ] ) ? { %{
$_
[ 0 ] } }
: (
$n
== 1 ) ? { __inline_args( 1,
@_
) }
: is_hashref(
$_
[ 1 ] ) ? {
name
=>
$_
[ 0 ], %{
$_
[ 1 ] } }
: (
$n
== 2 ) ? { __inline_args( 2,
@_
) }
: (
$n
== 3 ) ? { __inline_args( 3,
@_
) }
: {
@_
};
}
sub
__clone_one_of_us {
my
(
$self
,
$params
) =
@_
;
$self
->autoclose;
$self
->
reverse
;
$self
->
sort
;
my
$clone
= { %{
$self
}, %{
$params
// {} } };
my
$perms
=
delete
$clone
->{_perms};
$clone
->{perms} //=
$perms
;
return
$clone
;
}
sub
__coerce_name {
my
$name
=
shift
;
not
defined
$name
and
return
;
is_coderef
$name
and
$name
=
$name
->();
blessed
$name
and
$name
=
"${name}"
;
is_arrayref
$name
and
$name
= File::Spec->catfile( @{
$name
} );
curdir eq
$name
and
$name
= Cwd::getcwd();
first_char
$name
eq TILDE and
$name
= __expand_tilde(
$name
);
length
$name
> 1 and
$name
=~ s{ [/\\] \z }{}mx;
return
$name
;
}
sub
__expand_tilde {
(
my
$path
=
$_
[ 0 ]) =~ m{ \A ([~] [^/\\]*) .* }mx;
my
(
$dir
) =
glob
( $1 );
$path
=~ s{ \A ([~] [^/\\]*) }{
$dir
}mx;
return
$path
;
}
sub
__inline_args {
my
$n
=
shift
;
return
(
map
{
$ARG_NAMES
[
$_
] =>
$_
[
$_
] } 0 ..
$n
- 1);
}
sub
__is_one_of_us {
return
(blessed
$_
[ 0 ]) &&
$_
[ 0 ]->isa( __PACKAGE__ );
}
sub
abs2rel {
return
File::Spec->abs2rel(
$_
[ 0 ]->name,
$_
[ 1 ] );
}
sub
absolute {
my
(
$self
,
$base
) =
@_
;
$base
and
$base
= __coerce_name(
$base
);
$self
->_set_name(
$self
->name ?
$self
->rel2abs(
$base
) :
$base
);
return
$self
;
}
sub
all {
my
(
$self
,
$level
) =
@_
;
$self
->is_dir and
return
$self
->_find( TRUE, TRUE,
$level
);
return
$self
->_all_file_contents;
}
sub
all_dirs {
return
$_
[ 0 ]->_find( FALSE, TRUE,
$_
[ 1 ] );
}
sub
all_files {
return
$_
[ 0 ]->_find( TRUE, FALSE,
$_
[ 1 ] );
}
sub
_all_file_contents {
my
$self
=
shift
;
$self
->is_open or
$self
->assert_open;
local
$RS
=
undef
;
my
$content
=
$self
->io_handle->getline;
$self
->error_check;
$self
->autoclose and
$self
->
close
;
return
$content
;
}
sub
append {
my
(
$self
,
@args
) =
@_
;
if
(
$self
->is_open and not
$self
->is_reading) {
$self
->
seek
( 0, SEEK_END ) }
else
{
$self
->assert_open(
'a'
) }
return
$self
->_print(
@args
);
}
sub
appendln {
my
(
$self
,
@args
) =
@_
;
if
(
$self
->is_open and not
$self
->is_reading) {
$self
->
seek
( 0, SEEK_END ) }
else
{
$self
->assert_open(
'a'
) }
return
$self
->_println(
@args
);
}
sub
assert {
$_
[ 0 ]->_assert( TRUE );
return
$_
[ 0 ];
}
sub
assert_dirpath {
my
(
$self
,
$dir_name
) =
@_
;
$dir_name
or
return
; -d
$dir_name
and
return
$dir_name
;
my
$perms
=
$self
->_mkdir_perms;
$self
->_umask_push(
oct
'07777'
);
unless
(CORE::
mkdir
(
$dir_name
,
$perms
)) {
File::Path::make_path(
$dir_name
, {
mode
=>
$perms
} );
}
$self
->_umask_pop;
-d
$dir_name
or
$self
->_throw(
error
=>
'Path [_1] cannot create: [_2]'
,
args
=> [
$dir_name
,
$OS_ERROR
] );
return
$dir_name
;
}
sub
assert_filepath {
my
$self
=
shift
;
my
$dir
;
$self
->name or
$self
->_throw(
class
=> Unspecified,
args
=> [
'path name'
]);
(
undef
,
$dir
) = File::Spec->splitpath(
$self
->name );
$self
->assert_dirpath(
$dir
);
return
$self
;
}
sub
assert_open {
return
$_
[ 0 ]->
open
(
$_
[ 1 ] ||
'r'
,
$_
[ 2 ] );
}
sub
_assert_open_backwards {
my
(
$self
,
@args
) =
@_
;
$self
->is_open and
return
;
$self
->_set_io_handle( File::ReadBackwards->new(
$self
->name,
@args
) )
or
$self
->_throw(
error
=>
'File [_1] cannot open backwards: [_2]'
,
args
=> [
$self
->name,
$OS_ERROR
] );
$self
->_set_is_open( TRUE );
$self
->_set_mode(
'r'
);
$self
->set_lock;
$self
->set_binmode;
return
;
}
sub
atomic {
not
$NTFS
and
$_
[ 0 ]->_atomic( TRUE );
return
$_
[ 0 ];
}
sub
atomic_infix {
defined
$_
[ 1 ] and
$_
[ 0 ]->_atomic_infix(
$_
[ 1 ] );
return
$_
[ 0 ];
}
sub
atomic_suffix {
defined
$_
[ 1 ] and
$_
[ 0 ]->_atomic_infix(
$_
[ 1 ] );
return
$_
[ 0 ];
}
sub
backwards {
$_
[ 0 ]->_backwards( TRUE );
return
$_
[ 0 ];
}
sub
basename {
my
(
$self
,
@suffixes
) =
@_
;
$self
->name or
return
;
return
File::Basename::basename(
$self
->name,
@suffixes
);
}
sub
binary {
my
$self
=
shift
;
$self
->_push_layer(
':raw'
) and
$self
->is_open and
$self
->_sane_binmode;
return
$self
;
}
sub
binmode
{
my
(
$self
,
$layer
) =
@_
;
$self
->_push_layer(
$layer
)
and
$self
->is_open and
$self
->_sane_binmode(
$layer
);
return
$self
;
}
sub
block_size {
defined
$_
[ 1 ] and
$_
[ 0 ]->_block_size(
$_
[ 1 ] );
return
$_
[ 0 ];
}
sub
buffer {
my
$self
=
shift
;
if
(
@_
) {
my
$buffer_ref
=
ref
$_
[ 0 ] ?
$_
[ 0 ] : \
$_
[ 0 ];
defined
${
$buffer_ref
} or ${
$buffer_ref
} = NUL;
$self
->{buffer} =
$buffer_ref
;
return
$self
;
}
exists
$self
->{buffer} or
$self
->{buffer} =
do
{
my
$x
= NUL; \
$x
};
return
$self
->{buffer};
}
sub
_build__dir_pattern {
my
$self
=
shift
;
my
$pat
= NUL;
my
$curdir
= curdir;
my
$updir
= File::Spec->updir;
$curdir
and
$pat
=
"\Q${curdir}\E"
;
$curdir
and
$updir
and
$pat
.=
'|'
;
$updir
and
$pat
.=
"\Q${updir}\E"
;
return
qr{ \A (?:$pat) \z }
mx;
}
sub
canonpath {
return
File::Spec->canonpath(
$_
[ 0 ]->name );
}
sub
catdir {
my
(
$self
,
@rest
) =
@_
;
my
$params
= (is_hashref
$rest
[ -1 ]) ?
pop
@rest
: {};
my
$args
= [
grep
{
defined
and
length
}
$self
->name,
@rest
];
return
$self
->_constructor(
$args
,
$params
)->dir;
}
sub
catfile {
my
(
$self
,
@rest
) =
@_
;
my
$params
= (is_hashref
$rest
[ -1 ]) ?
pop
@rest
: {};
my
$args
= [
grep
{
defined
and
length
}
$self
->name,
@rest
];
return
$self
->_constructor(
$args
,
$params
)->file;
}
sub
chmod
{
my
(
$self
,
$perms
) =
@_
;
$perms
||=
$self
->_perms;
CORE::
chmod
$perms
,
$self
->name;
return
$self
;
}
sub
chomp
{
$_
[ 0 ]->_chomp( TRUE );
return
$_
[ 0 ];
}
sub
chown
{
my
(
$self
,
$uid
,
$gid
) =
@_
;
(
defined
$uid
and
defined
$gid
)
or
$self
->_throw(
class
=> Unspecified,
args
=> [
'user or group id'
] );
1 == CORE::
chown
$uid
,
$gid
,
$self
->name
or
$self
->_throw(
error
=>
'Path [_1 chown failed to [_2]/[_3]'
,
args
=> [
$self
->name,
$uid
,
$gid
] );
return
$self
;
}
sub
clear {
${
$_
[ 0 ]->buffer } = NUL;
return
$_
[ 0 ];
}
sub
close
{
my
$self
=
shift
;
$self
->is_open or
return
$self
;
if
(
$NTFS
) {
$self
->_close_and_rename }
else
{
$self
->_rename_and_close }
$self
->_set_io_handle(
undef
);
$self
->_set_is_open ( FALSE );
$self
->_set_mode (
'r'
);
return
$self
;
}
sub
_close_and_rename {
my
$self
=
shift
;
my
$handle
;
$self
->unlock;
if
(
$handle
=
$self
->io_handle) {
$handle
->
close
;
delete
$self
->{io_handle} }
$self
->_atomic and
$self
->_rename_atomic;
return
$self
;
}
sub
_rename_and_close {
my
$self
=
shift
;
my
$handle
;
$self
->_atomic and
$self
->_rename_atomic;
$self
->unlock;
if
(
$handle
=
$self
->io_handle) {
$handle
->
close
;
delete
$self
->{io_handle} }
return
$self
;
}
sub
_constructor {
my
$self
=
shift
;
return
(blessed
$self
)->new(
@_
);
}
sub
copy {
my
(
$self
,
$to
) =
@_
;
$to
or
$self
->_throw(
class
=> Unspecified,
args
=> [
'copy to'
] );
(blessed
$to
and
$to
->isa( __PACKAGE__ ))
or
$to
=
$self
->_constructor(
$to
);
File::Copy::copy(
$self
->name,
$to
->pathname )
or
$self
->_throw(
error
=>
'Cannot copy [_1] to [_2]'
,
args
=> [
$self
->name,
$to
->pathname ] );
return
$to
;
}
sub
cwd {
my
$self
=
shift
;
return
$self
->_constructor( Cwd::getcwd(),
@_
);
}
sub
deep {
$_
[ 0 ]->_deep( TRUE );
return
$_
[ 0 ];
}
sub
delete
{
my
$self
=
shift
;
my
$path
=
$self
->_get_atomic_path;
$self
->_atomic and -f
$path
and
unlink
$path
;
return
$self
->
close
;
}
sub
delete_tmp_files {
my
(
$self
,
$tmplt
) =
@_
;
$tmplt
||=
'%6.6d....'
;
my
$pat
=
sprintf
$tmplt
,
$PID
;
while
(
my
$entry
=
$self
->
next
) {
$entry
->filename =~ m{ \A
$pat
\z }mx and
unlink
$entry
->pathname;
}
return
$self
->
close
;
}
sub
DEMOLISH {
$_
[ 0 ]->_atomic ?
$_
[ 0 ]->
delete
:
$_
[ 0 ]->
close
;
return
;
}
sub
dir {
return
shift
->_init(
'dir'
,
@_
);
}
sub
dirname {
return
$_
[ 0 ]->name ? File::Basename::dirname(
$_
[ 0 ]->name ) :
undef
;
}
sub
encoding {
my
(
$self
,
$encoding
) =
@_
;
$encoding
or
$self
->_throw
(
class
=> Unspecified,
args
=> [
'encoding value'
] );
$self
->_push_layer(
":encoding($encoding)"
)
and
$self
->is_open and
$self
->_sane_binmode(
":encoding($encoding)"
);
return
$self
;
}
sub
error_check {
my
$self
=
shift
;
$self
->io_handle->can(
'error'
) or
return
;
$self
->io_handle->error or
return
;
$self
->_throw(
error
=>
'IO error: [_1]'
,
args
=> [
$OS_ERROR
] );
return
;
}
sub
exists
{
return
-e
$_
[ 0 ]->name;
}
sub
file {
return
shift
->_init(
'file'
,
@_
);
}
sub
filename {
my
$self
=
shift
;
my
$file
;
(
undef
,
undef
,
$file
) = File::Spec->splitpath(
$self
->name );
return
$file
;
}
sub
filepath {
my
$self
=
shift
;
my
(
$volume
,
$dir
) = File::Spec->splitpath(
$self
->name );
return
File::Spec->catpath(
$volume
,
$dir
, NUL );
}
sub
filter {
defined
$_
[ 1 ] and
$_
[ 0 ]->_filter(
$_
[ 1 ] );
return
$_
[ 0 ];
}
sub
_find {
my
(
$self
,
$files
,
$dirs
,
$level
) =
@_
;
my
(
@all
,
$io
);
my
$filter
=
$self
->_filter;
my
$follow
= not
$self
->_no_follow;
defined
$level
or
$level
=
$self
->_deep ? 0 : 1;
while
(
$io
=
$self
->
next
) {
my
$is_dir
=
$io
->is_dir;
defined
$is_dir
or
next
;
((
$files
and not
$is_dir
) or (
$dirs
and
$is_dir
))
and __include_path(
$filter
,
$io
) and
push
@all
,
$io
;
$is_dir
and (
$follow
or not
$io
->is_link) and
$level
!= 1
and
push
@all
,
$io
->_find(
$files
,
$dirs
,
$level
?
$level
- 1 : 0 );
}
not
$self
->
sort
and
return
@all
;
return
$self
->
reverse
?
reverse
sort
{
$a
->name cmp
$b
->name }
@all
:
sort
{
$a
->name cmp
$b
->name }
@all
;
}
sub
_get_atomic_path {
my
$self
=
shift
;
my
$path
=
$self
->filepath;
my
$file
;
my
$infix
=
$self
->_atomic_infix;
my
$tid
= thread_id;
$infix
=~ m{ \
%P
}mx and
$infix
=~ s{ \
%P
}{
$PID
}gmx;
$infix
=~ m{ \
%T
}mx and
$infix
=~ s{ \
%T
}{
$tid
}gmx;
if
(
$infix
=~ m{ \* }mx) {
my
$name
=
$self
->filename; (
$file
=
$infix
) =~ s{ \* }{
$name
}mx;
}
else
{
$file
=
$self
->filename.
$infix
}
return
$path
? File::Spec->catfile(
$path
,
$file
) :
$file
;
}
sub
getline {
my
(
$self
,
$separator
) =
@_
;
$self
->_backwards and
return
$self
->_getline_backwards;
my
$line
;
$self
->assert_open;
{
local
$RS
=
$separator
//
$self
->_separator;
$line
=
$self
->io_handle->getline;
defined
$line
and
$self
->_chomp and CORE::
chomp
$line
;
}
$self
->error_check;
defined
$line
and
return
$line
;
$self
->autoclose and
$self
->
close
;
return
;
}
sub
_getline_backwards {
my
(
$self
,
@args
) =
@_
;
$self
->_assert_open_backwards(
@args
);
return
$self
->io_handle->
readline
;
}
sub
getlines {
my
(
$self
,
$separator
) =
@_
;
$self
->_backwards and
return
$self
->_getlines_backwards;
my
@lines
;
$self
->assert_open;
{
local
$RS
=
$separator
//
$self
->_separator;
@lines
=
$self
->io_handle->getlines;
if
(
$self
->_chomp) { CORE::
chomp
for
@lines
}
}
$self
->error_check;
scalar
@lines
and
return
(
@lines
);
$self
->autoclose and
$self
->
close
;
return
();
}
sub
_getlines_backwards {
my
$self
=
shift
;
my
@lines
;
while
(
defined
(
my
$line
=
$self
->_getline_backwards)) {
push
@lines
,
$line
}
return
@lines
;
}
sub
head {
my
(
$self
,
$lines
) =
@_
;
my
@res
;
$lines
//= 10;
$self
->
close
;
while
(
$lines
--) {
defined
(
my
$l
=
$self
->getline) or
last
;
push
@res
,
$l
;
}
$self
->
close
;
return
wantarray
?
@res
:
join
NUL,
@res
;
}
sub
__include_path {
return
(not
defined
$_
[ 0 ] or (
map
{
$_
[ 0 ]->() } (
$_
[ 1 ]))[ 0 ]);
}
sub
_init {
my
(
$self
,
$type
,
$name
) =
@_
;
$self
->_set_io_handle(
undef
);
$self
->_set_is_open ( FALSE );
$self
->_set_name (
$name
)
if
(
$name
);
$self
->_set_mode (
'r'
);
$self
->_set_type (
$type
);
return
$self
;
}
sub
_init_type_from_fs {
my
$self
=
shift
;
$self
->name or
$self
->_throw(
class
=> Unspecified,
args
=> [
'path name'
]);
return
-f
$self
->name ?
$self
->file : -d _ ?
$self
->dir :
undef
;
}
sub
io (;@) {
return
__PACKAGE__->new(
@_
);
}
sub
is_absolute {
return
File::Spec->file_name_is_absolute(
$_
[ 0 ]->name );
}
sub
is_dir {
my
$self
=
shift
;
$self
->name or
return
FALSE;
$self
->type or
$self
->_init_type_from_fs or
return
FALSE;
return
$self
->type eq
'dir'
? TRUE : FALSE;
}
sub
is_empty {
my
$self
=
shift
;
my
$name
=
$self
->name;
my
$empty
;
$self
->
exists
or
$self
->_throw(
class
=> PathNotFound,
args
=> [
$name
] );
$self
->is_file and
return
-z
$name
? TRUE : FALSE;
$empty
=
$self
->
next
? FALSE : TRUE;
$self
->
close
;
return
$empty
;
}
*empty
= \
&is_empty
;
sub
is_executable {
return
$_
[ 0 ]->name && -x
$_
[ 0 ]->name ? TRUE : FALSE;
}
sub
is_file {
my
$self
=
shift
;
$self
->name or
return
FALSE;
$self
->type or
$self
->_init_type_from_fs;
return
$self
->type &&
$self
->type eq
'file'
? TRUE : FALSE;
}
sub
is_link {
return
$_
[ 0 ]->name && -l
$_
[ 0 ]->name ? TRUE : FALSE;
}
sub
is_readable {
return
$_
[ 0 ]->name && -r
$_
[ 0 ]->name ? TRUE : FALSE;
}
sub
is_reading {
my
$mode
=
$_
[ 1 ] ||
$_
[ 0 ]->mode;
return
first {
$_
eq
$mode
}
qw(r r+)
;
}
sub
is_writable {
return
$_
[ 0 ]->name && -w
$_
[ 0 ]->name ? TRUE : FALSE;
}
sub
is_writing {
my
$mode
=
$_
[ 1 ] ||
$_
[ 0 ]->mode;
return
first {
$_
eq
$mode
}
qw(a a+ w w+)
;
}
sub
iterator {
my
$self
=
shift
;
my
$deep
=
$self
->_deep;
my
@dirs
= (
$self
);
my
$filter
=
$self
->_filter;
my
$follow
= not
$self
->_no_follow;
return
sub
{
while
(
@dirs
) {
while
(
defined
(
my
$path
=
$dirs
[ 0 ]->
next
)) {
$deep
and
$path
->is_dir and (
$follow
or not
$path
->is_link)
and
unshift
@dirs
,
$path
;
__include_path(
$filter
,
$path
) and
return
$path
;
}
shift
@dirs
;
}
return
;
};
}
sub
length
{
return
length
${
$_
[ 0 ]->buffer };
}
sub
lock
{
$_
[ 0 ]->_lock(
$_
[ 1 ] // LOCK_BLOCKING );
return
$_
[ 0 ];
}
sub
mkdir
{
my
(
$self
,
$perms
) =
@_
;
$perms
||=
$self
->_mkdir_perms;
$self
->_umask_push(
oct
'07777'
);
CORE::
mkdir
(
$self
->name,
$perms
);
$self
->_umask_pop;
-d
$self
->name or
$self
->_throw(
error
=>
'Path [_1] cannot create: [_2]'
,
args
=> [
$self
->name,
$OS_ERROR
] );
return
$self
;
}
sub
_mkdir_perms {
my
$perms
=
$_
[ 1 ] ||
$_
[ 0 ]->_perms;
return
((
$perms
&
oct
'0444'
) >> 2) |
$perms
;
}
sub
mkpath {
my
(
$self
,
$perms
) =
@_
;
$perms
||=
$self
->_mkdir_perms;
$self
->_umask_push(
oct
'07777'
);
require
File::Path;
File::Path::make_path(
$self
->name, {
mode
=>
$perms
} );
$self
->_umask_pop;
-d
$self
->name or
$self
->_throw(
error
=>
'Path [_1] cannot create: [_2]'
,
args
=> [
$self
->name,
$OS_ERROR
] );
return
$self
;
}
sub
move {
my
(
$self
,
$to
) =
@_
;
$to
or
$self
->_throw(
class
=> Unspecified,
args
=> [
'move to'
] );
(blessed
$to
and
$to
->isa( __PACKAGE__ ))
or
$to
=
$self
->_constructor(
$to
);
File::Copy::move(
$self
->name,
$to
->pathname )
or
$self
->_throw(
error
=>
'Cannot move [_1] to [_2]'
,
args
=> [
$self
->name,
$to
->pathname ] );
return
$to
;
}
sub
next
{
my
$self
=
shift
;
defined
(
my
$name
=
$self
->read_dir) or
return
;
my
$io
=
$self
->_constructor( [
$self
->name,
$name
], {
reverse
=>
$self
->
reverse
,
sort
=>
$self
->
sort
} );
defined
$self
->_filter and
$io
->filter(
$self
->_filter );
return
$io
;
}
sub
no_follow {
$_
[ 0 ]->_no_follow( TRUE );
return
$_
[ 0 ];
}
sub
open
{
my
(
$self
,
$mode
,
$perms
) =
@_
;
$mode
||=
$self
->mode;
$self
->is_open
and first_char
$mode
eq first_char
$self
->mode
and
return
$self
;
$self
->is_open
and
'r'
eq first_char
$mode
and
'+'
eq (
substr
$self
->mode, 1, 1) || NUL
and
$self
->
seek
( 0, SEEK_SET )
and
return
$self
;
$self
->type or
$self
->_init_type_from_fs;
$self
->type or
$self
->file;
$self
->is_open and
$self
->
close
;
return
$self
->is_dir
?
$self
->_open_dir (
$self
->_open_args(
$mode
,
$perms
) )
:
$self
->_open_file(
$self
->_open_args(
$mode
,
$perms
) );
}
sub
_open_args {
my
(
$self
,
$mode
,
$perms
) =
@_
;
$self
->name or
$self
->_throw(
class
=> Unspecified,
args
=> [
'path name'
]);
my
$pathname
=
$self
->_atomic && !
$self
->is_reading(
$mode
)
?
$self
->_get_atomic_path :
$self
->name;
$perms
=
$self
->_untainted_perms ||
$perms
||
$self
->_perms;
return
(
$pathname
,
$self
->_set_mode(
$mode
),
$self
->_set__perms(
$perms
));
}
sub
_open_dir {
my
(
$self
,
$path
) =
@_
;
$self
->_assert and
$self
->assert_dirpath(
$path
);
$self
->_set_io_handle( IO::Dir->new(
$path
) )
or
$self
->_throw(
error
=>
'Directory [_1] cannot open'
,
args
=> [
$path
] );
$self
->_set_is_open( TRUE );
return
$self
;
}
sub
_open_file {
my
(
$self
,
$path
,
$mode
,
$perms
) =
@_
;
$self
->_assert and
$self
->assert_filepath;
$self
->_umask_push(
$perms
);
unless
(
$self
->_set_io_handle( IO::File->new(
$path
,
$mode
) )) {
$self
->_umask_pop;
$self
->_throw(
error
=>
'File [_1] cannot open'
,
args
=> [
$path
] );
}
$self
->_umask_pop;
$self
->is_writing and CORE::
chmod
$perms
,
$path
;
$self
->_set_is_open( TRUE );
$self
->set_lock;
$self
->set_binmode;
return
$self
;
}
sub
parent {
my
(
$self
,
$count
) =
@_
;
my
$parent
=
$self
;
$count
||= 1;
$parent
=
$self
->_constructor(
$parent
->dirname )
while
(
$count
--);
return
$parent
;
}
sub
pathname {
return
$_
[ 0 ]->name;
}
sub
perms {
defined
$_
[ 1 ] and
$_
[ 0 ]->_set__perms(
$_
[ 1 ] );
return
$_
[ 0 ];
}
sub
print
{
return
shift
->assert_open(
'w'
)->_print(
@_
);
}
sub
_print {
my
(
$self
,
@args
) =
@_
;
for
(
@args
) {
print
{
$self
->io_handle}
$_
or
$self
->_throw(
error
=>
'IO error: [_1]'
,
args
=> [
$OS_ERROR
] );
}
return
$self
;
}
sub
println {
return
shift
->assert_open(
'w'
)->_println(
@_
);
}
sub
_println {
return
shift
->_print(
map
{ m{ [\n] \z }mx ? (
$_
) : (
$_
,
"\n"
) }
@_
);
}
sub
_push_layer {
my
(
$self
,
$layer
) =
@_
;
$layer
//= NUL;
is_member
$layer
,
$self
->_layers and
return
FALSE;
push
@{
$self
->_layers },
$layer
;
return
TRUE;
}
sub
read
{
my
(
$self
,
@args
) =
@_
;
$self
->assert_open;
my
$length
=
@args
||
$self
->is_dir
?
$self
->io_handle->
read
(
@args
)
:
$self
->io_handle->
read
( ${
$self
->buffer },
$self
->_block_size,
$self
->
length
);
$self
->error_check;
return
$length
||
$self
->autoclose &&
$self
->
close
&& 0;
}
sub
read_dir {
my
$self
=
shift
;
my
$dir_pat
=
$self
->_dir_pattern;
my
$name
;
$self
->type or
$self
->dir;
$self
->assert_open;
$self
->is_link and
$self
->_no_follow and
$self
->
close
and
return
;
if
(
wantarray
) {
my
@names
=
grep
{
$_
!~
$dir_pat
}
$self
->io_handle->
read
;
$self
->
close
;
return
@names
;
}
while
(not
defined
$name
or
$name
=~
$dir_pat
) {
unless
(
defined
(
$name
=
$self
->io_handle->
read
)) {
$self
->
close
;
return
;
}
}
return
$name
;
}
sub
rel2abs {
my
(
$self
,
$base
) =
@_
;
return
File::Spec->rel2abs(
$self
->name,
defined
$base
?
"${base}"
:
undef
);
}
sub
relative {
$_
[ 0 ]->_set_name(
$_
[ 0 ]->abs2rel );
return
$_
[ 0 ];
}
sub
_rename_atomic {
my
$self
=
shift
;
my
$path
=
$self
->_get_atomic_path; -f
$path
or
return
;
File::Copy::move(
$path
,
$self
->name ) and
return
;
$NTFS
or
$self
->_throw(
error
=>
'Path [_1] move to [_2] failed: [_3]'
,
args
=> [
$path
,
$self
->name,
$OS_ERROR
] );
warn
'NTFS: Path '
.
$self
->name.
" move failure: ${OS_ERROR}\n"
;
eval
{
unlink
$self
->name };
my
$os_error
;
File::Copy::copy(
$path
,
$self
->name ) or
$os_error
=
$OS_ERROR
;
eval
{
unlink
$path
};
$os_error
and
$self
->_throw(
error
=>
'Path [_1] copy to [_2] failed: [_3]'
,
args
=> [
$path
,
$self
->name,
$os_error
] );
return
;
}
sub
reset
{
my
$self
=
shift
;
$self
->
close
;
$self
->_assert( FALSE );
$self
->_atomic( FALSE );
$self
->_chomp ( FALSE );
$self
->_deep ( FALSE );
$self
->_lock ( FALSE );
$self
->_no_follow( FALSE );
return
$self
;
}
sub
rmdir
{
my
$self
=
shift
;
CORE::
rmdir
$self
->name
or
$self
->_throw(
error
=>
'Path [_1] not removed: [_2]'
,
args
=> [
$self
->name,
$OS_ERROR
] );
return
$self
;
}
sub
rmtree {
return
File::Path::remove_tree(
$self
->name,
@args
);
}
sub
_sane_binmode {
my
(
$self
,
$layer
) =
@_
;
return
$layer
? CORE::
binmode
(
$self
->io_handle,
$layer
)
: CORE::
binmode
(
$self
->io_handle );
}
sub
seek
{
my
(
$self
,
@args
) =
@_
;
$self
->is_open or
$self
->assert_open(
$LC_OSNAME
eq EVIL ?
'r'
:
'r+'
);
$self
->io_handle->
seek
(
@args
);
$self
->error_check;
return
$self
;
}
sub
separator {
defined
$_
[ 1 ] and
$_
[ 0 ]->_separator(
$_
[ 1 ] );
return
$_
[ 0 ];
}
sub
set_binmode {
my
$self
=
shift
;
if
(
$NTFS
) {
is_member NUL,
$self
->_layers or
unshift
@{
$self
->_layers }, NUL;
}
$self
->_sane_binmode(
$_
)
for
(@{
$self
->_layers });
return
$self
;
}
sub
set_lock {
my
$self
=
shift
;
$self
->_lock or
return
;
my
$async
=
$self
->_lock == LOCK_NONBLOCKING ? TRUE : FALSE;
$self
->_lock_obj
and
return
$self
->_lock_obj->set(
k
=>
$self
->name,
async
=>
$async
);
my
$mode
=
$self
->mode eq
'r'
? LOCK_SH : LOCK_EX;
$async
and
$mode
|= LOCK_NB;
$self
->_set_have_lock(
flock
$self
->io_handle,
$mode
? TRUE : FALSE );
return
$self
;
}
sub
slurp {
my
$self
=
shift
;
my
$slurp
=
$self
->all;
wantarray
or
return
$slurp
;
local
$RS
=
$self
->_separator;
$self
->_chomp or
return
split
m{ (?<=\Q
$RS
\E) }mx,
$slurp
;
return
map
{ CORE::
chomp
;
$_
}
split
m{ (?<=\Q
$RS
\E) }mx,
$slurp
;
}
sub
splitdir {
return
File::Spec->splitdir(
$_
[ 0 ]->name );
}
sub
splitpath {
return
File::Spec->splitpath(
$_
[ 0 ]->name );
}
sub
stat
{
my
$self
=
shift
;
$self
->name or
return
{};
my
%stat_hash
= (
id
=>
$self
->filename );
@stat_hash
{ STAT_FIELDS() } =
stat
$self
->name;
return
\
%stat_hash
;
}
sub
substitute {
my
(
$self
,
$search
,
$replace
) =
@_
;
$search
or
return
$self
;
$replace
||= NUL;
my
$wtr
= io(
$self
->name )->perms(
$self
->_untainted_perms )->atomic;
for
(
$self
->getlines) { s{
$search
}{
$replace
}gmx;
$wtr
->
print
(
$_
) }
$self
->
close
;
$wtr
->
close
;
return
$self
;
}
sub
tail {
my
(
$self
,
$lines
,
@args
) =
@_
;
my
@res
;
$lines
//= 10;
$self
->
close
;
while
(
$lines
--) {
unshift
@res
, (
$self
->_getline_backwards(
@args
) or
last
);
}
$self
->
close
;
return
wantarray
?
@res
:
join
NUL,
@res
;
}
sub
tempfile {
my
(
$self
,
$tmplt
) =
@_
;
my
(
$tempdir
,
$tmpfh
);
require
File::Temp;
(
$tempdir
=
$self
->name and -d
$tempdir
) or
$tempdir
= File::Spec->tmpdir;
$tmplt
||=
'%6.6dXXXX'
;
$tmpfh
= File::Temp->new
(
DIR
=>
$tempdir
,
TEMPLATE
=> (
sprintf
$tmplt
,
$PID
) );
my
$t
=
$self
->_constructor(
$tmpfh
->filename )->file;
$t
->_set_io_handle(
$tmpfh
);
$t
->_set_is_open( TRUE );
$t
->_set_mode(
'w+'
);
return
$t
;
}
sub
_throw {
my
(
$self
,
@args
) =
@_
;
eval
{
$self
->unlock }; throw
@args
;
return
;
}
sub
touch {
my
(
$self
,
$time
) =
@_
;
$self
->name or
return
;
$time
//=
time
;
-e
$self
->name or
$self
->_open_file(
$self
->_open_args(
'w'
) )->
close
;
utime
$time
,
$time
,
$self
->name;
return
$self
;
}
sub
_umask_pop {
my
$self
=
shift
;
my
$perms
=
$self
->_umask->[ -1 ];
(
defined
$perms
and
$perms
!= NO_UMASK_STACK) or
return
umask
;
umask
pop
@{
$self
->_umask };
return
$perms
;
}
sub
_umask_push {
my
(
$self
,
$perms
) =
@_
;
$perms
or
return
umask
;
my
$first
=
$self
->_umask->[ 0 ];
defined
$first
and
$first
== NO_UMASK_STACK and
return
umask
;
$perms
^=
oct
'0777'
;
push
@{
$self
->_umask },
umask
$perms
;
return
$perms
;
}
sub
unlink
{
return
unlink
$_
[ 0 ]->name;
}
sub
unlock {
my
$self
=
shift
;
$self
->_lock or
return
;
my
$handle
=
$self
->io_handle;
if
(
$self
->_lock_obj) {
$self
->_lock_obj->
reset
(
k
=>
$self
->name ) }
else
{
$handle
and
$handle
->opened and
flock
$handle
, LOCK_UN }
$self
->_set_have_lock( FALSE );
return
$self
;
}
sub
_untainted_perms {
my
$self
=
shift
;
$self
->
exists
or
return
;
my
$perms
= 0;
$self
->
stat
->{mode} =~ m{ \A (\d+) \z }mx and
$perms
= $1;
return
$perms
&
oct
'07777'
;
}
sub
utf8 {
$_
[ 0 ]->encoding(
'UTF-8'
);
return
$_
[ 0 ];
}
sub
write
{
my
(
$self
,
@args
) =
@_
;
$self
->assert_open(
'w'
);
my
$length
=
@args
?
$self
->io_handle->
write
(
@args
)
:
$self
->io_handle->
write
( ${
$self
->buffer },
$self
->
length
);
$self
->error_check;
scalar
@args
or
$self
->clear;
return
$length
;
}
1;