← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:09 2021

Filename/usr/local/lib/perl5/site_perl/File/Copy/Recursive.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sFile::Copy::Recursive::::BEGIN@11File::Copy::Recursive::BEGIN@11
0000s0sFile::Copy::Recursive::::BEGIN@12File::Copy::Recursive::BEGIN@12
0000s0sFile::Copy::Recursive::::BEGIN@13File::Copy::Recursive::BEGIN@13
0000s0sFile::Copy::Recursive::::BEGIN@14File::Copy::Recursive::BEGIN@14
0000s0sFile::Copy::Recursive::::BEGIN@16File::Copy::Recursive::BEGIN@16
0000s0sFile::Copy::Recursive::::BEGIN@3File::Copy::Recursive::BEGIN@3
0000s0sFile::Copy::Recursive::::BEGIN@5File::Copy::Recursive::BEGIN@5
0000s0sFile::Copy::Recursive::::BEGIN@9File::Copy::Recursive::BEGIN@9
0000s0sFile::Copy::Recursive::::CORE:symlinkFile::Copy::Recursive::CORE:symlink (opcode)
0000s0sFile::Copy::Recursive::::__ANON__File::Copy::Recursive::__ANON__ (xsub)
0000s0sFile::Copy::Recursive::::__ANON__[:123]File::Copy::Recursive::__ANON__[:123]
0000s0sFile::Copy::Recursive::::__ANON__[:137]File::Copy::Recursive::__ANON__[:137]
0000s0sFile::Copy::Recursive::::__ANON__[:318]File::Copy::Recursive::__ANON__[:318]
0000s0sFile::Copy::Recursive::::__ANON__[:84]File::Copy::Recursive::__ANON__[:84]
0000s0sFile::Copy::Recursive::::__ANON__[:99]File::Copy::Recursive::__ANON__[:99]
0000s0sFile::Copy::Recursive::::_bail_if_changedFile::Copy::Recursive::_bail_if_changed
0000s0sFile::Copy::Recursive::::dircopyFile::Copy::Recursive::dircopy
0000s0sFile::Copy::Recursive::::dirmoveFile::Copy::Recursive::dirmove
0000s0sFile::Copy::Recursive::::fcopyFile::Copy::Recursive::fcopy
0000s0sFile::Copy::Recursive::::fmoveFile::Copy::Recursive::fmove
0000s0sFile::Copy::Recursive::::pathemptyFile::Copy::Recursive::pathempty
0000s0sFile::Copy::Recursive::::pathmkFile::Copy::Recursive::pathmk
0000s0sFile::Copy::Recursive::::pathrmFile::Copy::Recursive::pathrm
0000s0sFile::Copy::Recursive::::pathrmdirFile::Copy::Recursive::pathrmdir
0000s0sFile::Copy::Recursive::::rcopyFile::Copy::Recursive::rcopy
0000s0sFile::Copy::Recursive::::rcopy_globFile::Copy::Recursive::rcopy_glob
0000s0sFile::Copy::Recursive::::rmoveFile::Copy::Recursive::rmove
0000s0sFile::Copy::Recursive::::rmove_globFile::Copy::Recursive::rmove_glob
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package File::Copy::Recursive;
2
3use strict;
4
5BEGIN {
6 # Keep older versions of Perl from trying to use lexical warnings
7 $INC{'warnings.pm'} = "fake warnings entry for < 5.6 perl ($])" if $] < 5.006;
8}
9use warnings;
10
11use Carp;
12use File::Copy;
13use File::Spec; #not really needed because File::Copy already gets it, but for good measure :)
14use Cwd ();
15
16use vars qw(
17 @ISA @EXPORT_OK $VERSION $MaxDepth $KeepMode $CPRFComp $CopyLink
18 $PFSCheck $RemvBase $NoFtlPth $ForcePth $CopyLoop $RMTrgFil $RMTrgDir
19 $CondCopy $BdTrgWrn $SkipFlop $DirPerms
20);
21
22require Exporter;
23@ISA = qw(Exporter);
24@EXPORT_OK = qw(fcopy rcopy dircopy fmove rmove dirmove pathmk pathrm pathempty pathrmdir rcopy_glob rmove_glob);
25
26$VERSION = '0.45';
27
28$MaxDepth = 0;
29$KeepMode = 1;
30$CPRFComp = 0;
31$CopyLink = eval { local $SIG{'__DIE__'}; symlink '', ''; 1 } || 0;
32$PFSCheck = 1;
33$RemvBase = 0;
34$NoFtlPth = 0;
35$ForcePth = 0;
36$CopyLoop = 0;
37$RMTrgFil = 0;
38$RMTrgDir = 0;
39$CondCopy = {};
40$BdTrgWrn = 0;
41$SkipFlop = 0;
42$DirPerms = 0777;
43
44my $samecheck = sub {
45 return 1 if $^O eq 'MSWin32'; # need better way to check for this on winders...
46 return if @_ != 2 || !defined $_[0] || !defined $_[1];
47 return if $_[0] eq $_[1];
48
49 my $one = '';
50 if ($PFSCheck) {
51 $one = join( '-', ( stat $_[0] )[ 0, 1 ] ) || '';
52 my $two = join( '-', ( stat $_[1] )[ 0, 1 ] ) || '';
53 if ( $one eq $two && $one ) {
54 carp "$_[0] and $_[1] are identical";
55 return;
56 }
57 }
58
59 if ( -d $_[0] && !$CopyLoop ) {
60 $one = join( '-', ( stat $_[0] )[ 0, 1 ] ) if !$one;
61 my $abs = File::Spec->rel2abs( $_[1] );
62 my @pth = File::Spec->splitdir($abs);
63 while (@pth) {
64 if ( $pth[-1] eq '..' ) { # cheaper than Cwd::realpath() plus we don't want to resolve symlinks at this point, right?
65 pop @pth;
66 pop @pth unless -l File::Spec->catdir(@pth);
67 next;
68 }
69 my $cur = File::Spec->catdir(@pth);
70 last if !$cur; # probably not necessary, but nice to have just in case :)
71 my $two = join( '-', ( stat $cur )[ 0, 1 ] ) || '';
72 if ( $one eq $two && $one ) {
73
74 # $! = 62; # Too many levels of symbolic links
75 carp "Caught Deep Recursion Condition: $_[0] contains $_[1]";
76 return;
77 }
78
79 pop @pth;
80 }
81 }
82
83 return 1;
84};
85
86my $glob = sub {
87 my ( $do, $src_glob, @args ) = @_;
88
89 local $CPRFComp = 1;
90 require File::Glob;
91
92 my @rt;
93 for my $path ( File::Glob::bsd_glob($src_glob) ) {
94 my @call = [ $do->( $path, @args ) ] or return;
95 push @rt, \@call;
96 }
97
98 return @rt;
99};
100
101my $move = sub {
102 my $fl = shift;
103 my @x;
104 if ($fl) {
105 @x = fcopy(@_) or return;
106 }
107 else {
108 @x = dircopy(@_) or return;
109 }
110 if (@x) {
111 if ($fl) {
112 unlink $_[0] or return;
113 }
114 else {
115 pathrmdir( $_[0] ) or return;
116 }
117 if ($RemvBase) {
118 my ( $volm, $path ) = File::Spec->splitpath( $_[0] );
119 pathrm( File::Spec->catpath( $volm, $path, '' ), $ForcePth, $NoFtlPth ) or return;
120 }
121 }
122 return wantarray ? @x : $x[0];
123};
124
125my $ok_todo_asper_condcopy = sub {
126 my $org = shift;
127 my $copy = 1;
128 if ( exists $CondCopy->{$org} ) {
129 if ( $CondCopy->{$org}{'md5'} ) {
130
131 }
132 if ($copy) {
133
134 }
135 }
136 return $copy;
137};
138
139sub fcopy {
140 $samecheck->(@_) or return;
141 if ( $RMTrgFil && ( -d $_[1] || -e $_[1] ) ) {
142 my $trg = $_[1];
143 if ( -d $trg ) {
144 my @trgx = File::Spec->splitpath( $_[0] );
145 $trg = File::Spec->catfile( $_[1], $trgx[$#trgx] );
146 }
147 $samecheck->( $_[0], $trg ) or return;
148 if ( -e $trg ) {
149 if ( $RMTrgFil == 1 ) {
150 unlink $trg or carp "\$RMTrgFil failed: $!";
151 }
152 else {
153 unlink $trg or return;
154 }
155 }
156 }
157 my ( $volm, $path ) = File::Spec->splitpath( $_[1] );
158 if ( $path && !-d $path ) {
159 pathmk( File::Spec->catpath( $volm, $path, '' ), $NoFtlPth );
160 }
161 if ( -l $_[0] && $CopyLink ) {
162 my $target = readlink( shift() );
163 ($target) = $target =~ m/(.*)/; # mass-untaint is OK since we have to allow what the file system does
164 carp "Copying a symlink ($_[0]) whose target does not exist"
165 if !-e $target && $BdTrgWrn;
166 my $new = shift();
167 unlink $new if -l $new;
168 symlink( $target, $new ) or return;
169 }
170 elsif ( -d $_[0] && -f $_[1] ) {
171 return;
172 }
173 else {
174 return if -d $_[0]; # address File::Copy::copy() bug outlined in https://rt.perl.org/Public/Bug/Display.html?id=132866
175 copy(@_) or return;
176
177 my @base_file = File::Spec->splitpath( $_[0] );
178 my $mode_trg = -d $_[1] ? File::Spec->catfile( $_[1], $base_file[$#base_file] ) : $_[1];
179
180 chmod scalar( ( stat( $_[0] ) )[2] ), $mode_trg if $KeepMode;
181 }
182 return wantarray ? ( 1, 0, 0 ) : 1; # use 0's incase they do math on them and in case rcopy() is called in list context = no uninit val warnings
183}
184
185sub rcopy {
186 if ( -l $_[0] && $CopyLink ) {
187 goto &fcopy;
188 }
189
190 goto &dircopy if -d $_[0] || substr( $_[0], ( 1 * -1 ), 1 ) eq '*';
191 goto &fcopy;
192}
193
194sub rcopy_glob {
195 $glob->( \&rcopy, @_ );
196}
197
198sub dircopy {
199 if ( $RMTrgDir && -d $_[1] ) {
200 if ( $RMTrgDir == 1 ) {
201 pathrmdir( $_[1] ) or carp "\$RMTrgDir failed: $!";
202 }
203 else {
204 pathrmdir( $_[1] ) or return;
205 }
206 }
207 my $globstar = 0;
208 my $_zero = $_[0];
209 my $_one = $_[1];
210 if ( substr( $_zero, ( 1 * -1 ), 1 ) eq '*' ) {
211 $globstar = 1;
212 $_zero = substr( $_zero, 0, ( length($_zero) - 1 ) );
213 }
214
215 $samecheck->( $_zero, $_[1] ) or return;
216 if ( !-d $_zero || ( -e $_[1] && !-d $_[1] ) ) {
217 $! = 20;
218 return;
219 }
220
221 if ( !-d $_[1] ) {
222 pathmk( $_[1], $NoFtlPth ) or return;
223 }
224 else {
225 if ( $CPRFComp && !$globstar ) {
226 my @parts = File::Spec->splitdir($_zero);
227 while ( $parts[$#parts] eq '' ) { pop @parts; }
228 $_one = File::Spec->catdir( $_[1], $parts[$#parts] );
229 }
230 }
231 my $baseend = $_one;
232 my $level = 0;
233 my $filen = 0;
234 my $dirn = 0;
235
236 my $recurs; #must be my()ed before sub {} since it calls itself
237 $recurs = sub {
238 my ( $str, $end, $buf ) = @_;
239 $filen++ if $end eq $baseend;
240 $dirn++ if $end eq $baseend;
241
242 $DirPerms = oct($DirPerms) if substr( $DirPerms, 0, 1 ) eq '0';
243 mkdir( $end, $DirPerms ) or return if !-d $end;
244 if ( $MaxDepth && $MaxDepth =~ m/^\d+$/ && $level >= $MaxDepth ) {
245 chmod scalar( ( stat($str) )[2] ), $end if $KeepMode;
246 return ( $filen, $dirn, $level ) if wantarray;
247 return $filen;
248 }
249
250 $level++;
251
252 my @files;
253 if ( $] < 5.006 ) {
254 opendir( STR_DH, $str ) or return;
255 @files = grep( $_ ne '.' && $_ ne '..', readdir(STR_DH) );
256 closedir STR_DH;
257 }
258 else {
259 opendir( my $str_dh, $str ) or return;
260 @files = grep( $_ ne '.' && $_ ne '..', readdir($str_dh) );
261 closedir $str_dh;
262 }
263
264 for my $file (@files) {
265 my ($file_ut) = $file =~ m{ (.*) }xms;
266 my $org = File::Spec->catfile( $str, $file_ut );
267 my $new = File::Spec->catfile( $end, $file_ut );
268 if ( -l $org && $CopyLink ) {
269 my $target = readlink($org);
270 ($target) = $target =~ m/(.*)/; # mass-untaint is OK since we have to allow what the file system does
271 carp "Copying a symlink ($org) whose target does not exist"
272 if !-e $target && $BdTrgWrn;
273 unlink $new if -l $new;
274 symlink( $target, $new ) or return;
275 }
276 elsif ( -d $org ) {
277 my $rc;
278 if ( !-w $org && $KeepMode ) {
279 local $KeepMode = 0;
280 $rc = $recurs->( $org, $new, $buf ) if defined $buf;
281 $rc = $recurs->( $org, $new ) if !defined $buf;
282 chmod scalar( ( stat($org) )[2] ), $new;
283 }
284 else {
285 $rc = $recurs->( $org, $new, $buf ) if defined $buf;
286 $rc = $recurs->( $org, $new ) if !defined $buf;
287 }
288 if ( !$rc ) {
289 if ($SkipFlop) {
290 next;
291 }
292 else {
293 return;
294 }
295 }
296 $filen++;
297 $dirn++;
298 }
299 else {
300 if ( $ok_todo_asper_condcopy->($org) ) {
301 if ($SkipFlop) {
302 fcopy( $org, $new, $buf ) or next if defined $buf;
303 fcopy( $org, $new ) or next if !defined $buf;
304 }
305 else {
306 fcopy( $org, $new, $buf ) or return if defined $buf;
307 fcopy( $org, $new ) or return if !defined $buf;
308 }
309 chmod scalar( ( stat($org) )[2] ), $new if $KeepMode;
310 $filen++;
311 }
312 }
313 }
314 $level--;
315 chmod scalar( ( stat($str) )[2] ), $end if $KeepMode;
316 1;
317
318 };
319
320 $recurs->( $_zero, $_one, $_[2] ) or return;
321 return wantarray ? ( $filen, $dirn, $level ) : $filen;
322}
323
324sub fmove { $move->( 1, @_ ) }
325
326sub rmove {
327 if ( -l $_[0] && $CopyLink ) {
328 goto &fmove;
329 }
330
331 goto &dirmove if -d $_[0] || substr( $_[0], ( 1 * -1 ), 1 ) eq '*';
332 goto &fmove;
333}
334
335sub rmove_glob {
336 $glob->( \&rmove, @_ );
337}
338
339sub dirmove { $move->( 0, @_ ) }
340
341sub pathmk {
342 my ( $vol, $dir, $file ) = File::Spec->splitpath( shift() );
343 my $nofatal = shift;
344
345 $DirPerms = oct($DirPerms) if substr( $DirPerms, 0, 1 ) eq '0';
346
347 if ( defined($dir) ) {
348 my (@dirs) = File::Spec->splitdir($dir);
349
350 for ( my $i = 0; $i < scalar(@dirs); $i++ ) {
351 my $newdir = File::Spec->catdir( @dirs[ 0 .. $i ] );
352 my $newpth = File::Spec->catpath( $vol, $newdir, "" );
353
354 mkdir( $newpth, $DirPerms ) or return if !-d $newpth && !$nofatal;
355 mkdir( $newpth, $DirPerms ) if !-d $newpth && $nofatal;
356 }
357 }
358
359 if ( defined($file) ) {
360 my $newpth = File::Spec->catpath( $vol, $dir, $file );
361
362 mkdir( $newpth, $DirPerms ) or return if !-d $newpth && !$nofatal;
363 mkdir( $newpth, $DirPerms ) if !-d $newpth && $nofatal;
364 }
365
366 1;
367}
368
369sub pathempty {
370 my $pth = shift;
371
372 my ( $orig_dev, $orig_ino ) = ( lstat $pth )[ 0, 1 ];
373 return 2 if !-d _ || !defined($orig_dev) || ( $^O ne 'MSWin32' && !$orig_ino ); #stat.inode is 0 on Windows
374
375 my $starting_point = Cwd::cwd();
376 my ( $starting_dev, $starting_ino ) = ( lstat $starting_point )[ 0, 1 ];
377 chdir($pth) or Carp::croak("Failed to change directory to “$pth”: $!");
378 $pth = '.';
379 _bail_if_changed( $pth, $orig_dev, $orig_ino );
380
381 my @names;
382 my $pth_dh;
383 if ( $] < 5.006 ) {
384 opendir( PTH_DH, $pth ) or return;
385 @names = grep !/^\.\.?$/, readdir(PTH_DH);
386 closedir PTH_DH;
387 }
388 else {
389 opendir( $pth_dh, $pth ) or return;
390 @names = grep !/^\.\.?$/, readdir($pth_dh);
391 closedir $pth_dh;
392 }
393 _bail_if_changed( $pth, $orig_dev, $orig_ino );
394
395 for my $name (@names) {
396 my ($name_ut) = $name =~ m{ (.*) }xms;
397 my $flpth = File::Spec->catdir( $pth, $name_ut );
398
399 if ( -l $flpth ) {
400 _bail_if_changed( $pth, $orig_dev, $orig_ino );
401 unlink $flpth or return;
402 }
403 elsif ( -d $flpth ) {
404 _bail_if_changed( $pth, $orig_dev, $orig_ino );
405 pathrmdir($flpth) or return;
406 }
407 else {
408 _bail_if_changed( $pth, $orig_dev, $orig_ino );
409 unlink $flpth or return;
410 }
411 }
412
413 chdir($starting_point) or Carp::croak("Failed to change directory to “$starting_point”: $!");
414 _bail_if_changed( ".", $starting_dev, $starting_ino );
415
416 return 1;
417}
418
419sub pathrm {
420 my ( $path, $force, $nofail ) = @_;
421
422 my ( $orig_dev, $orig_ino ) = ( lstat $path )[ 0, 1 ];
423 return 2 if !-d _ || !defined($orig_dev) || !$orig_ino;
424
425 # Manual test (I hate this function :/):
426 # sudo mkdir /foo && perl -MFile::Copy::Recursive=pathrm -le 'print pathrm("/foo",1)' && sudo rm -rf /foo
427 if ( $force && File::Spec->file_name_is_absolute($path) ) {
428 Carp::croak("pathrm() w/ force on abspath is not allowed");
429 }
430
431 my @pth = File::Spec->splitdir($path);
432
433 my %fs_check;
434 my $aggregate_path;
435 for my $part (@pth) {
436 $aggregate_path = defined $aggregate_path ? File::Spec->catdir( $aggregate_path, $part ) : $part;
437 $fs_check{$aggregate_path} = [ ( lstat $aggregate_path )[ 0, 1 ] ];
438 }
439
440 while (@pth) {
441 my $cur = File::Spec->catdir(@pth);
442 last if !$cur; # necessary ???
443
444 if ($force) {
445 _bail_if_changed( $cur, $fs_check{$cur}->[0], $fs_check{$cur}->[1] );
446 if ( !pathempty($cur) ) {
447 return unless $nofail;
448 }
449 }
450 _bail_if_changed( $cur, $fs_check{$cur}->[0], $fs_check{$cur}->[1] );
451 if ($nofail) {
452 rmdir $cur;
453 }
454 else {
455 rmdir $cur or return;
456 }
457 pop @pth;
458 }
459
460 return 1;
461}
462
463sub pathrmdir {
464 my $dir = shift;
465 if ( -e $dir ) {
466 return if !-d $dir;
467 }
468 else {
469 return 2;
470 }
471
472 my ( $orig_dev, $orig_ino ) = ( lstat $dir )[ 0, 1 ];
473 return 2 if !defined($orig_dev) || ( $^O ne 'MSWin32' && !$orig_ino );
474
475 pathempty($dir) or return;
476 _bail_if_changed( $dir, $orig_dev, $orig_ino );
477 rmdir $dir or return;
478
479 return 1;
480}
481
482sub _bail_if_changed {
483 my ( $path, $orig_dev, $orig_ino ) = @_;
484
485 my ( $cur_dev, $cur_ino ) = ( lstat $path )[ 0, 1 ];
486
487 if ( !defined $cur_dev || !defined $cur_ino ) {
488 $cur_dev ||= "undef(path went away?)";
489 $cur_ino ||= "undef(path went away?)";
490 }
491 else {
492 $path = Cwd::abs_path($path);
493 }
494
495 if ( $orig_dev ne $cur_dev || $orig_ino ne $cur_ino ) {
496 local $Carp::CarpLevel += 1;
497 Carp::croak("directory $path changed: expected dev=$orig_dev ino=$orig_ino, actual dev=$cur_dev ino=$cur_ino, aborting");
498 }
499}
500
5011;
502
503__END__