File Coverage

blib/lib/Pcore/Util/File.pm
Criterion Covered Total %
statement 94 418 22.4
branch 35 248 14.1
condition 11 109 10.0
subroutine 12 37 32.4
pod 0 30 0.0
total 152 842 18.0


line stmt bran cond sub pod time code
1             package Pcore::Util::File;
2              
3 5     5   30 use Pcore;
  5         10  
  5         44  
4 5     5   32 use Pcore::Util::Scalar qw[is_glob is_plain_arrayref is_plain_hashref];
  5         10  
  5         32  
5 5     5   29 use Fcntl qw[:DEFAULT];
  5         10  
  5         1725  
6 5     5   32 use Cwd qw[]; ## no critic qw[Modules::ProhibitEvilModules]
  5         7  
  5         87  
7 5     5   19 use Config;
  5         11  
  5         29399  
8              
9             sub cat_path {
10 0     0 0 0 return P->path( join q[/], splice @_, 1 );
11             }
12              
13             # return cwd, symlinks are resolved
14             sub cwd {
15 5     5 0 145 return P->path( Cwd::realpath(q[.]), is_dir => 1 );
16             }
17              
18 0     0 0 0 sub chdir ($path) { ## no critic qw[Subroutines::ProhibitBuiltinHomonyms]
  0         0  
  0         0  
19 0 0       0 if ( defined wantarray ) {
    0          
20 0         0 my $cwd = cwd->to_string;
21              
22 0 0       0 return unless chdir $path;
23              
24 0         0 state $init = !!require Pcore::Util::File::ChdirGuard;
25              
26 0         0 return Pcore::Util::File::ChdirGuard->new( { dir => $cwd } )->scope_guard;
27             }
28             elsif ( chdir $path ) {
29 0         0 return;
30             }
31             else {
32 0         0 die qq[Can't chdir to "$path"];
33             }
34             }
35              
36             # change umask and return old umask
37 0     0 0 0 sub umask ($mode) { ## no critic qw[Subroutines::ProhibitBuiltinHomonyms]
  0         0  
  0         0  
38 0 0       0 return '00' if $MSWIN;
39              
40 0 0       0 if ( defined wantarray ) {
41 0         0 state $init = !!require Pcore::Util::File::UmaskGuard;
42              
43 0         0 return Pcore::Util::File::UmaskGuard->new( { old_umask => CORE::umask calc_umask($mode) } );
44             }
45             else {
46 0         0 return CORE::umask calc_umask($mode);
47             }
48             }
49              
50 0     0 0 0 sub calc_umask ( $mode, % ) {
  0         0  
  0         0  
51 0 0       0 return unless defined $mode;
52              
53 0         0 my %args = (
54             oct => 0,
55             splice @_, 1,
56             );
57              
58 0 0       0 if ( $mode =~ /[^[:digit:]]/smi ) {
59 0         0 state $mode_cache = {};
60              
61 0 0       0 if ( !exists $mode_cache->{$mode} ) {
62 0         0 my $mode_val = 0b111_111_111; # all perms are disabled by default
63              
64 0         0 my @mode = map {lc} split //sm, $mode;
  0         0  
65              
66             # user
67 0 0 0     0 $mode_val &= 0b011_111_111 if defined $mode[0] && $mode[0] eq q[r];
68 0 0 0     0 $mode_val &= 0b101_111_111 if defined $mode[1] && $mode[1] eq q[w];
69 0 0 0     0 $mode_val &= 0b110_111_111 if defined $mode[2] && $mode[2] eq q[x];
70              
71             # group
72 0 0 0     0 $mode_val &= 0b111_011_111 if defined $mode[3] && $mode[3] eq q[r];
73 0 0 0     0 $mode_val &= 0b111_101_111 if defined $mode[4] && $mode[4] eq q[w];
74 0 0 0     0 $mode_val &= 0b111_110_111 if defined $mode[5] && $mode[5] eq q[x];
75              
76             # other
77 0 0 0     0 $mode_val &= 0b111_111_011 if defined $mode[6] && $mode[6] eq q[r];
78 0 0 0     0 $mode_val &= 0b111_111_101 if defined $mode[7] && $mode[7] eq q[w];
79 0 0 0     0 $mode_val &= 0b111_111_110 if defined $mode[8] && $mode[8] eq q[x];
80              
81 0         0 $mode_cache->{$mode} = $mode_val;
82             }
83              
84 0         0 $mode = $mode_cache->{$mode};
85             }
86             else {
87 0 0       0 $mode = oct $mode if substr( $mode, 0, 1 ) eq '0';
88             }
89              
90 0 0       0 return $args{oct} ? sprintf '0%o', $mode : $mode;
91             }
92              
93             # mkdir with chmod support
94 0     0 0 0 sub mkdir ( $path, $mode = undef ) { ## no critic qw[Subroutines::ProhibitBuiltinHomonyms]
  0         0  
  0         0  
  0         0  
95 0 0       0 if ( defined wantarray ) {
96 0 0       0 if ( defined $mode ) {
97 0         0 return mkdir $path, calc_chmod($mode);
98             }
99             else {
100 0         0 return mkdir $path;
101             }
102             }
103             else {
104 0 0       0 if ( defined $mode ) {
105 0 0       0 mkdir $path, calc_chmod($mode) or die qq[Can't mkdir "$path". $!];
106             }
107             else {
108 0 0       0 mkdir $path or die qq[Can't mkdir "$path". $!];
109             }
110              
111 0         0 return;
112             }
113             }
114              
115 0     0 0 0 sub chmod ( $mode, @path ) { ## no critic qw[Subroutines::ProhibitBuiltinHomonyms]
  0         0  
  0         0  
  0         0  
116 0 0       0 if ( defined wantarray ) {
117 0         0 return CORE::chmod calc_chmod($mode), @path;
118             }
119             else {
120 0   0     0 return CORE::chmod( calc_chmod($mode), @path ) || die qq[$! during chmod $mode, ] . join q[, ], @path;
121             }
122             }
123              
124 10     10 0 23 sub calc_chmod ( $mode, % ) {
  10         16  
  10         26  
125 10 50       29 return unless defined $mode;
126              
127 10         40 my %args = (
128             oct => 0,
129             splice @_, 1,
130             );
131              
132 10 50       46 if ( $mode =~ /[^[:digit:]]/smi ) {
133 10         25 state $mode_cache = {};
134              
135 10 100       543 if ( !exists $mode_cache->{$mode} ) {
136 5         15 my $mode_val = 0; # all perms are disabled by default
137              
138 5         318 my @mode = map {lc} split //sm, $mode;
  45         107  
139              
140             # user
141 5 50 33     42 $mode_val |= 0b100_000_000 if defined $mode[0] && $mode[0] eq q[r];
142 5 50 33     31 $mode_val |= 0b010_000_000 if defined $mode[1] && $mode[1] eq q[w];
143 5 50 33     28 $mode_val |= 0b001_000_000 if defined $mode[2] && $mode[2] eq q[x];
144              
145             # group
146 5 50 33     46 $mode_val |= 0b000_100_000 if defined $mode[3] && $mode[3] eq q[r];
147 5 50 33     29 $mode_val |= 0b000_010_000 if defined $mode[4] && $mode[4] eq q[w];
148 5 50 33     28 $mode_val |= 0b000_001_000 if defined $mode[5] && $mode[5] eq q[x];
149              
150             # other
151 5 50 33     27 $mode_val |= 0b000_000_100 if defined $mode[6] && $mode[6] eq q[r];
152 5 50 33     25 $mode_val |= 0b000_000_010 if defined $mode[7] && $mode[7] eq q[w];
153 5 50 33     24 $mode_val |= 0b000_000_001 if defined $mode[8] && $mode[8] eq q[x];
154              
155 5         20 $mode_cache->{$mode} = $mode_val;
156             }
157              
158 10         26 $mode = $mode_cache->{$mode};
159             }
160             else {
161 0 0       0 $mode = oct $mode if substr( $mode, 0, 1 ) eq '0';
162             }
163              
164 10 50       456 return $args{oct} ? sprintf '0%o', $mode : $mode;
165             }
166              
167             # READ / WRITE
168 8     8 0 21 sub read_bin ( $path, % ) {
  8         19  
  8         16  
169 8         48 my %args = (
170             cb => undef,
171             buf_size => 1_048_576,
172             splice @_, 1,
173             );
174              
175 8         35 my $fh = get_fh( $path, O_RDONLY, crlf => 0 );
176              
177 8         27 my $tail = q[];
178              
179             READ:
180 16         232 my $bytes = read $fh, my $buf, $args{buf_size};
181              
182 16 50       53 die qq[Couldn't read file "$path": $!] if !defined $bytes;
183              
184 16 50       48 if ( $args{cb} ) {
185 0 0       0 if ($bytes) {
186 0 0       0 return if !$args{cb}->( \$buf );
187              
188 0         0 goto READ;
189             }
190             else {
191 0         0 $args{cb}->(undef);
192              
193 0         0 return;
194             }
195             }
196             else {
197 16 100       38 if ($bytes) {
198 8         33 $tail .= $buf;
199              
200 8         62 goto READ;
201             }
202             else {
203 8         97 return \$tail;
204             }
205             }
206             }
207              
208 2     2 0 3 sub read_text ( $path, % ) {
  2         5  
  2         4  
209 2         12 my %args = (
210             crlf => 1, # undef - auto, 1 - on, 0 - off (for binary files)
211             binmode => ':encoding(UTF-8)',
212             cb => undef,
213             buf_size => 1_048_576,
214             splice @_, 1,
215             );
216              
217 2         10 my $fh = get_fh( $path, O_RDONLY, crlf => $args{crlf}, binmode => $args{binmode} );
218              
219 2         7 my $tail = q[];
220              
221             READ:
222 4         1811 my $bytes = read $fh, my $buf, $args{buf_size};
223              
224 4 50       5317 die qq[Couldn't read file "$path": $!] if !defined $bytes;
225              
226 4 50       14 if ( $args{cb} ) {
227 0 0       0 if ($bytes) {
228 0 0       0 return if !$args{cb}->( \$buf );
229              
230 0         0 goto READ;
231             }
232             else {
233 0         0 $args{cb}->(undef);
234              
235 0         0 return;
236             }
237             }
238             else {
239 4 100       11 if ($bytes) {
240 2         207 $tail .= $buf;
241              
242 2         14 goto READ;
243             }
244             else {
245 2         5695 return \$tail;
246             }
247             }
248             }
249              
250 0     0 0 0 sub read_lines ( $path, % ) {
  0         0  
  0         0  
251 0         0 my %args = (
252             crlf => 1, # undef - auto, 1 - on, 0 - off (for binary files)
253             binmode => ':encoding(UTF-8)',
254             cb => undef,
255             buf_size => 1_048_576,
256             empty_lines => 0, # only for array_ref mode, don't skip empty lines
257             splice @_, 1,
258             );
259              
260 0         0 my $fh = get_fh( $path, O_RDONLY, crlf => $args{crlf}, binmode => $args{binmode} );
261              
262 0         0 my $tail = q[];
263              
264             READ:
265 0         0 my $bytes = read $fh, my $buf, $args{buf_size};
266              
267 0 0       0 die qq[Couldn't read file "$path": $!] if !defined $bytes;
268              
269 0 0       0 if ( $args{cb} ) {
270 0 0       0 if ($bytes) {
271 0 0       0 if ( index( $buf, qq[\n] ) == -1 ) { # buf doesn't contains strings
272 0         0 $tail .= $buf;
273             }
274             else { # buf contains strings
275 0         0 $buf = $tail . $buf;
276              
277 0 0       0 if ( $args{empty_lines} ) {
278 0         0 my $array_ref = [ split /\n/sm, $buf, -1 ];
279              
280 0         0 $tail = pop $array_ref->@*;
281              
282 0 0       0 return if !$args{cb}->($array_ref);
283             }
284             else {
285 0         0 my $array_ref = [ split /\n+/sm, $buf ];
286              
287             # remove leading q[], preserved by split
288 0 0 0     0 shift $array_ref->@* if defined $array_ref->[0] && $array_ref->[0] eq q[];
289              
290 0 0       0 if ( substr( $buf, -1, 1 ) ne qq[\n] ) {
291 0         0 $tail = pop $array_ref->@*;
292             }
293             else {
294 0         0 $tail = q[];
295             }
296              
297 0 0       0 if ( $array_ref->@* ) {
298 0 0       0 return if !$args{cb}->($array_ref);
299             }
300             }
301             }
302              
303 0         0 goto READ;
304             }
305             else {
306 0 0       0 if ( $tail ne q[] ) {
307 0 0       0 return if !$args{cb}->( [$tail] );
308             }
309              
310 0         0 $args{cb}->(undef);
311              
312 0         0 return;
313             }
314             }
315             else {
316 0 0       0 if ($bytes) {
317 0         0 $tail .= $buf;
318              
319 0         0 goto READ;
320             }
321             else {
322 0 0       0 if ( $args{empty_lines} ) {
323 0         0 my $array_ref = [ split /\n/sm, $tail, -1 ];
324              
325             # remove trailing q[], preserved by split
326 0 0 0     0 pop $array_ref->@* if defined $array_ref->[-1] && $array_ref->[-1] eq q[];
327              
328 0         0 return $array_ref;
329             }
330             else {
331 0         0 my $array_ref = [ split /\n+/sm, $tail ];
332              
333             # remove leading q[], preserved by split
334 0 0 0     0 shift $array_ref->@* if defined $array_ref->[0] && $array_ref->[0] eq q[];
335              
336 0         0 return $array_ref;
337             }
338             }
339             }
340             }
341              
342             sub write_bin {
343 0     0 0 0 my $path = shift;
344             my %args = (
345             mode => 'rw-------',
346             umask => undef,
347             autoflush => 1,
348 0 0       0 ( is_plain_hashref $_[0] ? %{ shift @_ } : () ),
  0         0  
349             );
350              
351 0         0 _write_to_fh( get_fh( $path, O_WRONLY | O_CREAT | O_TRUNC, %args, crlf => 0 ), @_ );
352              
353 0         0 return;
354             }
355              
356             sub append_bin {
357 0     0 0 0 my $path = shift;
358             my %args = (
359             mode => 'rw-------',
360             umask => undef,
361             autoflush => 1,
362 0 0       0 ( is_plain_hashref $_[0] ? %{ shift @_ } : () ),
  0         0  
363             );
364              
365 0         0 _write_to_fh( get_fh( $path, O_WRONLY | O_CREAT | O_APPEND, %args, crlf => 0 ), @_ );
366              
367 0         0 return;
368             }
369              
370             sub write_text {
371 0     0 0 0 my $path = shift;
372             my %args = (
373             crlf => undef, # undef - auto, 1 - on, 0 - off (for binary files)
374             binmode => ':encoding(UTF-8)',
375             autoflush => 1,
376             mode => 'rw-------',
377             umask => undef,
378 0 0       0 ( is_plain_hashref $_[0] ? %{ shift @_ } : () ),
  0         0  
379             );
380              
381 0         0 _write_to_fh( get_fh( $path, O_WRONLY | O_CREAT | O_TRUNC, %args ), @_ );
382              
383 0         0 return;
384             }
385              
386             sub append_text {
387 0     0 0 0 my $path = shift;
388             my %args = (
389             crlf => undef, # undef - auto, 1 - on, 0 - off (for binary files)
390             binmode => ':encoding(UTF-8)',
391             autoflush => 1,
392             mode => 'rw-------',
393             umask => undef,
394 0 0       0 ( is_plain_hashref $_[0] ? %{ shift @_ } : () ),
  0         0  
395             );
396              
397 0         0 _write_to_fh( get_fh( $path, O_WRONLY | O_CREAT | O_APPEND, %args ), @_ );
398              
399 0         0 return;
400             }
401              
402 10     10 0 20 sub encode_path ($path) {
  10         22  
  10         15  
403 10 50       31 if ($MSWIN) {
404 0         0 state $enc = Encode::find_encoding($Pcore::WIN_ENC);
405              
406 0 0       0 return $enc->encode( $path, Encode::FB_CROAK ) if utf8::is_utf8($path);
407             }
408              
409 10         23 return $path;
410             }
411              
412 10     10 0 21 sub get_fh ( $path, $mode, @ ) {
  10         19  
  10         19  
  10         14  
413 10         87 my %args = (
414             mode => 'rw-------',
415             umask => undef,
416             crlf => 0, # undef - auto, 1 - on, 0 - off (for binary files)
417             binmode => undef,
418             autoflush => 1,
419             splice @_, 2,
420             );
421              
422 10 50       54 if ( is_glob $path ) {
423 0         0 return $path;
424             }
425             else {
426 10         23 my $umask_guard;
427              
428 10 50       37 $umask_guard = &umask( $args{umask} ) if defined $args{umask}; ## no critic qw[Subroutines::ProhibitAmpersandSigils]
429              
430             # encode filename to native OS encoding
431 10         33 $path = encode_path($path);
432              
433 10 50       69 sysopen my $fh, $path, $mode, calc_chmod( $args{mode} ) or die qq[Can't open file "$path"];
434              
435 10         36 my $binmode = q[];
436              
437 10 0 33     40 $args{crlf} //= $MSWIN ? 1 : 0;
438              
439 10 100       43 if ( $args{crlf} ) {
440 2 50       7 $binmode = ':crlf' if !$MSWIN;
441             }
442             else {
443 8 50       28 $binmode = ':raw' if $MSWIN;
444             }
445              
446 10 100       40 $binmode .= $args{binmode} if $args{binmode};
447              
448 10 100 50     52 binmode $fh, $binmode or die qq[Can't set binmode file "$path"] if $binmode;
449              
450 10 50       542 $fh->autoflush(1) if $args{autoflush};
451              
452 10         32021 return $fh;
453             }
454             }
455              
456             sub _write_to_fh {
457 0     0   0 my $fh = shift;
458              
459 0         0 for my $str (@_) {
460 0 0       0 if ( is_plain_arrayref $str ) {
    0          
461 0         0 for my $line ( $str->@* ) {
462 0         0 print {$fh} $line, qq[\n];
  0         0  
463             }
464             }
465             elsif ( ref $str eq 'SCALAR' ) {
466 0         0 print {$fh} $str->$*;
  0         0  
467             }
468             else {
469 0         0 print {$fh} $str;
  0         0  
470             }
471             }
472              
473 0         0 return;
474             }
475              
476             # READ DIR
477 0     0 0 0 sub read_dir ( $path, % ) {
  0         0  
  0         0  
478 0         0 my %args = (
479             keep_dot => 0,
480             full_path => 0,
481             splice @_, 1,
482             );
483              
484 0 0       0 opendir my $dh, $path or die qq[Can't open dir "$path"];
485              
486 0         0 my $files;
487              
488 0 0       0 if ( $args{keep_dot} ) {
489 0         0 $files = [ readdir $dh ];
490             }
491             else {
492 0 0       0 $files = [ grep { $_ ne q[.] && $_ ne q[..] } readdir $dh ];
  0         0  
493             }
494              
495 0 0       0 if ( $args{full_path} ) {
496 0         0 my $path = P->path( $path, is_dir => 1 );
497              
498 0         0 $files = [ map { $path . $_ } $files->@* ];
  0         0  
499             }
500              
501 0 0       0 closedir $dh or die;
502              
503 0         0 return $files;
504             }
505              
506             # TOUCH
507 0     0 0 0 sub touch ( $path, % ) {
  0         0  
  0         0  
508 0         0 my %args = (
509             atime => undef,
510             mtime => undef,
511             mode => q[rw-------],
512             umask => undef,
513             splice @_, 1,
514             );
515              
516 0         0 $path = encode_path($path);
517              
518 0 0       0 if ( !-e $path ) {
519              
520             # set umask if defined
521 0 0       0 my $umask_guard = defined $args{umask} ? &umask( $args{umask} ) : undef; ## no critic qw[Subroutines::ProhibitAmpersandSigils]
522              
523 0 0       0 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"];
524              
525 0 0       0 close $FH or die;
526             }
527              
528             # set utime
529 0   0     0 $args{atime} //= $args{mtime} // time;
      0        
530 0   0     0 $args{mtime} //= $args{atime};
531 0 0       0 utime $args{atime}, $args{mtime}, $path or die;
532              
533 0         0 return;
534             }
535              
536             # MKPATH, RMTREE, EMPTY_DIR
537 0     0 0 0 sub mkpath ( $path, % ) {
  0         0  
  0         0  
538 0         0 my %args = (
539             mode => q[rwx------],
540             umask => undef,
541             splice @_, 1,
542             );
543              
544 0         0 state $init = !!require File::Path;
545              
546 0         0 $args{mode} = calc_chmod( $args{mode} );
547              
548 0 0       0 my $umask_guard = defined $args{umask} ? &umask( delete $args{umask} ) : delete $args{umask}; ## no critic qw[Subroutines::ProhibitAmpersandSigils]
549              
550 0         0 return File::Path::make_path( "$path", \%args );
551             }
552              
553 0     0 0 0 sub rmtree ( $path, @ ) {
  0         0  
  0         0  
554 0         0 my %args = (
555             safe => 0, # 0 - will attempts to alter file permission
556             keep_root => 0,
557             splice @_, 1,
558             );
559              
560 0         0 state $init = !!require File::Path;
561              
562 0         0 my $error;
563              
564 0         0 $args{error} = \$error;
565              
566 0         0 my $removed = File::Path::remove_tree( "$path", \%args );
567              
568 0 0       0 return $error->@* ? () : 1;
569             }
570              
571 0     0 0 0 sub empty_dir ( $path, @ ) {
  0         0  
  0         0  
572 0         0 my %args = (
573             safe => 0, # 0 - will attempts to alter file permission
574             splice @_, 1,
575             keep_root => 1,
576             );
577              
578 0         0 state $init = !!require File::Path;
579              
580 0         0 return File::Path::remove_tree( "$path", \%args );
581             }
582              
583             # TEMP
584 0     0 0 0 sub tempfile (%args) {
  0         0  
  0         0  
585 0         0 state $init = !!require Pcore::Util::File::TempFile;
586              
587 0         0 return Pcore::Util::File::TempFile->new(%args);
588             }
589              
590 5     5 0 10 sub tempdir (%args) {
  5         18  
  5         7  
591 5         1562 state $init = !!require Pcore::Util::File::TempDir;
592              
593 5         31 return Pcore::Util::File::TempDir->new( \%args );
594             }
595              
596             sub temppath {
597             my %args = (
598             base => $ENV->{TEMP_DIR},
599 0     0 0   suffix => q[],
600             tmpl => 'temp-' . $$ . '-XXXXXXXX',
601             @_,
602             );
603              
604 0 0 0       $args{suffix} = q[.] . $args{suffix} if defined $args{suffix} && $args{suffix} ne q[] && substr( $args{suffix}, 0, 1 ) ne q[.];
      0        
605              
606 0           state $init = !!require Pcore::Util::File::TempFile;
607              
608 0 0         mkpath( $args{base} ) if !-e $args{base};
609              
610 0           my $attempt = 3;
611              
612 0 0         REDO:
613             die q[Can't create temporary path] if !$attempt--;
614              
615 0           my $filename = $args{tmpl} =~ s/X/$Pcore::Util::File::TempFile::TMPL->[rand $Pcore::Util::File::TempFile::TMPL->@*]/smger . $args{suffix};
  0            
616              
617 0 0         goto REDO if -e $args{base} . q[/] . $filename;
618              
619 0           return P->path( $args{base} . q[/] . $filename );
620             }
621              
622             # COPY / MOVE FILE
623 0     0 0   sub copy ( $from, $to, @ ) {
  0            
  0            
  0            
624 0           my %args = (
625             glob => undef,
626             dir_mode => q[rwxr-xr-x],
627             umask => undef,
628             buf_size => undef,
629             copy_link => 0, # if 1 - symlinks will be copied as symlinks
630             rm_file => 1, # remove target file before copying, 0 - off, 1 - die if can't remove, 2 - return if can't remove
631             rm_dir => 1, # remove target dir before copying, 0 - off, 1 - die if can't remove, 2 - return if can't remove
632             pfs_check => 1,
633             cprf => 1, # only if $to is dir, if $to/ is exists put $from/ content into $to/ instead of replace $to/ with $from/
634             splice @_, 2,
635             );
636              
637 0 0         my $umask_guard = defined $args{umask} ? &umask( $args{umask} ) : undef; ## no critic qw[Subroutines::ProhibitAmpersandSigils]
638              
639 0           local $File::Copy::Recursive::DirPerms = calc_chmod( $args{dir_mode}, oct => 1 );
640 0           local $File::Copy::Recursive::CopyLink = $args{copy_link};
641 0           local $File::Copy::Recursive::RMTrgFil = $args{rm_file};
642 0           local $File::Copy::Recursive::RMTrgDir = $args{rm_dir};
643 0           local $File::Copy::Recursive::PFSCheck = $args{pfs_check};
644 0           local $File::Copy::Recursive::CPRFComp = $args{cprf};
645              
646 0           state $init = !!require File::Copy::Recursive;
647              
648 0 0         if ( -d $from ) {
    0          
649 0 0         if ( $args{glob} ) {
650 0   0       return File::Copy::Recursive::rcopy_glob( qq[$from/$args{glob}], $to, $args{buf_size} // () );
651             }
652             else {
653 0   0       return File::Copy::Recursive::dircopy( $from, $to, $args{buf_size} // () );
654             }
655             }
656             elsif ( -f $from ) {
657 0   0       return File::Copy::Recursive::fcopy( $from, $to, $args{buf_size} // () );
658             }
659             else {
660 0           die qq[Source "$from" not exists];
661             }
662              
663 0           return;
664             }
665              
666 0     0 0   sub move ( $from, $to, @ ) {
  0            
  0            
  0            
667 0           my %args = (
668             dir_mode => q[rwxr-xr-x],
669             umask => undef,
670             buf_size => undef,
671             copy_link => 0, # if 1 - symlinks will be copied as symlinks
672             rm_file => 1, # remove target file before copying, 0 - off, 1 - die if can't remove, 2 - return if can't remove
673             rm_dir => 1, # remove target dir before copying, 0 - off, 1 - die if can't remove, 2 - return if can't remove
674             pfs_check => 1,
675             cprf => 1, # only if $to is dir, if $to/ is exists put $from/ content into $to/ instead of replace $to/ with $from/
676             splice @_, 2,
677             );
678              
679 0 0         my $umask_guard = defined $args{umask} ? &umask( $args{umask} ) : undef; ## no critic qw[Subroutines::ProhibitAmpersandSigils]
680              
681 0           local $File::Copy::Recursive::DirPerms = calc_chmod( $args{dir_mode}, oct => 1 );
682 0           local $File::Copy::Recursive::CopyLink = $args{copy_link};
683 0           local $File::Copy::Recursive::RMTrgFil = $args{rm_file};
684 0           local $File::Copy::Recursive::RMTrgDir = $args{rm_dir};
685 0           local $File::Copy::Recursive::PFSCheck = $args{pfs_check};
686 0           local $File::Copy::Recursive::CPRFComp = $args{cprf};
687              
688 0           state $init = !!require File::Copy::Recursive;
689              
690 0 0         if ( -d $from ) {
    0          
691 0 0         if ( $args{glob} ) {
692 0   0       return File::Copy::Recursive::rmove_glob( qq[$from/$args{glob}], $to, $args{buf_size} // () );
693             }
694             else {
695 0   0       return File::Copy::Recursive::dirmove( $from, $to, $args{buf_size} // () );
696             }
697             }
698             elsif ( -f $from ) {
699 0   0       return File::Copy::Recursive::fmove( $from, $to, $args{buf_size} // () );
700             }
701             else {
702 0           die qq[Source "$from" not exists];
703             }
704              
705 0           return;
706             }
707              
708             # FIND
709 0     0 0   sub find ( $path, @ ) {
  0            
  0            
710 0           my %args = (
711             abs => 0, # return absolute path
712             dir => 1, # return found dirs
713             file => 1, # return found files
714             splice @_, 1, -1,
715             );
716              
717 0 0         $path = P->path( $path, is_dir => 1 )->realpath or return;
718              
719 0           my $cb = $_[-1];
720              
721 0           my $chdir_guard;
722              
723 0 0         $chdir_guard = &chdir($path) if !$args{abs}; ## no critic qw[Subroutines::ProhibitAmpersandSigils]
724              
725 0           my $read_dir;
726              
727 0     0     $read_dir = sub ($dirpath) {
  0            
  0            
728 0           for my $file ( read_dir($dirpath)->@* ) {
729 0           $file = $dirpath . q[/] . Encode::decode( $Pcore::WIN_ENC, $file, Encode::FB_CROAK );
730              
731 0 0         if ( -d $file ) {
732 0           $file = P->path( $file, is_dir => 1 );
733              
734 0 0         $cb->($file) if $args{dir};
735              
736 0           $read_dir->($file);
737             }
738             else {
739 0           $file = P->path( $file, is_dir => 0 );
740              
741 0 0         $cb->($file) if $args{file};
742             }
743             }
744              
745 0           return;
746 0           };
747              
748 0 0         $read_dir->( $args{abs} ? $path : q[./] );
749              
750 0           return;
751             }
752              
753             # WHERE
754 0     0 0   sub where ( $filename ) {
  0            
  0            
755 0           my $wantarray = wantarray;
756              
757 0           state $env_path = q[];
758              
759 0           state $paths;
760              
761 0 0         if ( $env_path ne $ENV{PATH} ) {
762 0           $env_path = $ENV{PATH};
763              
764 0           $paths = [ q[.], grep {$_} split /$Config{path_sep}/sm, $ENV{PATH} ];
  0            
765             }
766              
767 0           state $env_pathext = q[];
768              
769 0           state $pathext = [q[]];
770              
771 0 0 0       if ( $MSWIN && $ENV{PATHEXT} && $env_pathext ne $ENV{PATHEXT} ) {
      0        
772 0           $env_pathext = $ENV{PATHEXT};
773              
774 0           $pathext = [ q[], grep {$_} split /$Config{path_sep}/sm, $ENV{PATHEXT} ];
  0            
775             }
776              
777 0           my @res;
778              
779 0           for my $path ( $paths->@* ) {
780 0           for my $ext ( $pathext->@* ) {
781 0 0         if ( -e "$path/${filename}${ext}" ) {
782 0 0         if ($wantarray) {
783 0           push @res, P->path("$path/${filename}${ext}")->realpath;
784             }
785             else {
786 0           return P->path("$path/${filename}${ext}")->realpath;
787             }
788             }
789             }
790             }
791              
792 0           return @res;
793             }
794              
795             # UNTAR
796 0     0 0   sub untar ( $tar, $target, @ ) {
  0            
  0            
  0            
797 0           state $init = !!require Archive::Tar;
798              
799 0           my %args = (
800             strip_component => 0,
801             splice @_, 2,
802             );
803              
804 0           $tar = Archive::Tar->new($tar);
805              
806 0           my $strip_component;
807              
808             my @extracted;
809              
810 0           for my $file ( $tar->get_files ) {
811 0 0         next if !$file->is_file;
812              
813 0           my $path = P->path( q[/] . $file->full_path )->to_string;
814              
815 0 0         if ( $args{strip_component} ) {
816 0 0         if ( !$strip_component ) {
817 0           my @labels = split m[/]sm, $path;
818              
819 0 0         die q[Can't strip component, path is too short] if @labels < $args{strip_component};
820              
821 0           $strip_component = P->path( q[/] . join( q[/], splice @labels, 0, $args{strip_component} + 1 ) )->to_string;
822             }
823              
824 0 0         die qq[Can't strip component "$strip_component" from path "$path"] if $path !~ s[\A$strip_component][]sm;
825             }
826              
827 0           my $target_path = P->path("$target/$path");
828              
829 0 0         P->file->mkpath( $target_path->dirname ) if !-e $target_path->dirname;
830              
831 0 0         if ( $file->extract($target_path) ) {
832 0           push @extracted, $target_path;
833             }
834             else {
835 0           die qq[Can't extract "$path"];
836             }
837             }
838              
839 0           return \@extracted;
840             }
841              
842             1;
843             ## -----SOURCE FILTER LOG BEGIN-----
844             ##
845             ## PerlCritic profile "pcore-script" policy violations:
846             ## +------+----------------------+----------------------------------------------------------------------------------------------------------------+
847             ## | Sev. | Lines | Policy |
848             ## |======+======================+================================================================================================================|
849             ## | 3 | | Subroutines::ProhibitExcessComplexity |
850             ## | | 50 | * Subroutine "calc_umask" with high complexity score (25) |
851             ## | | 124 | * Subroutine "calc_chmod" with high complexity score (25) |
852             ## | | 250 | * Subroutine "read_lines" with high complexity score (27) |
853             ## |------+----------------------+----------------------------------------------------------------------------------------------------------------|
854             ## | 1 | 821 | CodeLayout::ProhibitParensWithBuiltins - Builtin function called with parentheses |
855             ## +------+----------------------+----------------------------------------------------------------------------------------------------------------+
856             ##
857             ## -----SOURCE FILTER LOG END-----
858             __END__
859             =pod
860              
861             =encoding utf8
862              
863             =head1 NAME
864              
865             Pcore::Util::File
866              
867             =head1 SYNOPSIS
868              
869             =head1 DESCRIPTION
870              
871             =cut