← Index
NYTProf Performance Profile   « line view »
For rbm/rbm
  Run on Wed Feb 12 03:38:15 2020
Reported on Wed Feb 12 04:56:36 2020

Filename/usr/share/perl5/File/Copy/Recursive.pm
StatementsExecuted 168 statements in 4.27ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
611466µs606msFile::Copy::Recursive::::fcopyFile::Copy::Recursive::fcopy
611419µs558µsFile::Copy::Recursive::::__ANON__[:84]File::Copy::Recursive::__ANON__[:84]
1831166µs166µsFile::Copy::Recursive::::CORE:statFile::Copy::Recursive::CORE:stat (opcode)
3051139µs139µsFile::Copy::Recursive::::CORE:ftdirFile::Copy::Recursive::CORE:ftdir (opcode)
61158µs58µsFile::Copy::Recursive::::CORE:chmodFile::Copy::Recursive::CORE:chmod (opcode)
11117µs22µsFile::Copy::Recursive::::BEGIN@3File::Copy::Recursive::BEGIN@3
11111µs11µsFile::Copy::Recursive::::CORE:symlinkFile::Copy::Recursive::CORE:symlink (opcode)
61110µs10µsFile::Copy::Recursive::::CORE:ftlinkFile::Copy::Recursive::CORE:ftlink (opcode)
11110µs11µsFile::Copy::Recursive::::BEGIN@13File::Copy::Recursive::BEGIN@13
1118µs48µsFile::Copy::Recursive::::BEGIN@11File::Copy::Recursive::BEGIN@11
1118µs151µsFile::Copy::Recursive::::BEGIN@16File::Copy::Recursive::BEGIN@16
1118µs39µsFile::Copy::Recursive::::BEGIN@9File::Copy::Recursive::BEGIN@9
1116µs88µsFile::Copy::Recursive::::BEGIN@12File::Copy::Recursive::BEGIN@12
1114µs4µsFile::Copy::Recursive::::BEGIN@5File::Copy::Recursive::BEGIN@5
1113µs3µsFile::Copy::Recursive::::BEGIN@14File::Copy::Recursive::BEGIN@14
111600ns600nsFile::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__[:319]File::Copy::Recursive::__ANON__[:319]
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::::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
3251µs227µs
# spent 22µs (17+5) within File::Copy::Recursive::BEGIN@3 which was called: # once (17µs+5µs) by RBM::BEGIN@15 at line 3
use strict;
# spent 22µs making 1 call to File::Copy::Recursive::BEGIN@3 # spent 5µs making 1 call to strict::import
4
5
# spent 4µs within File::Copy::Recursive::BEGIN@5 which was called: # once (4µs+0s) by RBM::BEGIN@15 at line 8
BEGIN {
6 # Keep older versions of Perl from trying to use lexical warnings
714µs $INC{'warnings.pm'} = "fake warnings entry for < 5.6 perl ($])" if $] < 5.006;
8116µs14µs}
# spent 4µs making 1 call to File::Copy::Recursive::BEGIN@5
9224µs271µs
# spent 39µs (8+31) within File::Copy::Recursive::BEGIN@9 which was called: # once (8µs+31µs) by RBM::BEGIN@15 at line 9
use warnings;
# spent 39µs making 1 call to File::Copy::Recursive::BEGIN@9 # spent 32µs making 1 call to warnings::import
10
11222µs288µs
# spent 48µs (8+40) within File::Copy::Recursive::BEGIN@11 which was called: # once (8µs+40µs) by RBM::BEGIN@15 at line 11
use Carp;
# spent 48µs making 1 call to File::Copy::Recursive::BEGIN@11 # spent 40µs making 1 call to Exporter::import
12221µs2170µs
# spent 88µs (6+82) within File::Copy::Recursive::BEGIN@12 which was called: # once (6µs+82µs) by RBM::BEGIN@15 at line 12
use File::Copy;
# spent 88µs making 1 call to File::Copy::Recursive::BEGIN@12 # spent 82µs making 1 call to Exporter::import
13229µs211µs
# spent 11µs (10+600ns) within File::Copy::Recursive::BEGIN@13 which was called: # once (10µs+600ns) by RBM::BEGIN@15 at line 13
use File::Spec; #not really needed because File::Copy already gets it, but for good measure :)
# spent 11µs making 1 call to File::Copy::Recursive::BEGIN@13 # spent 600ns making 1 call to File::Copy::Recursive::__ANON__
14234µs13µs
# spent 3µs within File::Copy::Recursive::BEGIN@14 which was called: # once (3µs+0s) by RBM::BEGIN@15 at line 14
use Cwd ();
# spent 3µs making 1 call to File::Copy::Recursive::BEGIN@14
15
1617µs1143µs
# spent 151µs (8+143) within File::Copy::Recursive::BEGIN@16 which was called: # once (8µs+143µs) by RBM::BEGIN@15 at line 20
use vars qw(
# spent 143µs making 1 call to vars::import
17 @ISA @EXPORT_OK $VERSION $MaxDepth $KeepMode $CPRFComp $CopyLink
18 $PFSCheck $RemvBase $NoFtlPth $ForcePth $CopyLoop $RMTrgFil $RMTrgDir
19 $CondCopy $BdTrgWrn $SkipFlop $DirPerms
2012.76ms1151µs);
# spent 151µs making 1 call to File::Copy::Recursive::BEGIN@16
21
2211µsrequire Exporter;
2319µs@ISA = qw(Exporter);
2411µs@EXPORT_OK = qw(fcopy rcopy dircopy fmove rmove dirmove pathmk pathrm pathempty pathrmdir rcopy_glob rmove_glob);
25
261200ns$VERSION = '0.44';
27
281100ns$MaxDepth = 0;
291100ns$KeepMode = 1;
3010s$CPRFComp = 0;
31424µs111µs$CopyLink = eval { local $SIG{'__DIE__'}; symlink '', ''; 1 } || 0;
# spent 11µs making 1 call to File::Copy::Recursive::CORE:symlink
321100ns$PFSCheck = 1;
331100ns$RemvBase = 0;
341100ns$NoFtlPth = 0;
351100ns$ForcePth = 0;
361100ns$CopyLoop = 0;
371100ns$RMTrgFil = 0;
381100ns$RMTrgDir = 0;
391400ns$CondCopy = {};
401200ns$BdTrgWrn = 0;
411100ns$SkipFlop = 0;
421100ns$DirPerms = 0777;
43
44
# spent 558µs (419+139) within File::Copy::Recursive::__ANON__[/usr/share/perl5/File/Copy/Recursive.pm:84] which was called 6 times, avg 93µs/call: # 6 times (419µs+139µs) by File::Copy::Recursive::fcopy at line 140, avg 93µs/call
my $samecheck = sub {
45617µs return 1 if $^O eq 'MSWin32'; # need better way to check for this on winders...
46618µs return if @_ != 2 || !defined $_[0] || !defined $_[1];
4765µs return if $_[0] eq $_[1];
48
49612µs my $one = '';
5066µs if ($PFSCheck) {
516171µs619µs $one = join( '-', ( stat $_[0] )[ 0, 1 ] ) || '';
# spent 19µs making 6 calls to File::Copy::Recursive::CORE:stat, avg 3µs/call
526145µs6109µs my $two = join( '-', ( stat $_[1] )[ 0, 1 ] ) || '';
# spent 109µs making 6 calls to File::Copy::Recursive::CORE:stat, avg 18µs/call
5364µs if ( $one eq $two && $one ) {
54 carp "$_[0] and $_[1] are identical";
55 return;
56 }
57 }
58
596149µs610µs if ( -d $_[0] && !$CopyLoop ) {
# spent 10µs making 6 calls to File::Copy::Recursive::CORE:ftdir, avg 2µs/call
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
83627µs return 1;
8414µs};
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;
9912µs};
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];
12312µs};
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;
13711µs};
138
139
# spent 606ms (466µs+606) within File::Copy::Recursive::fcopy which was called 6 times, avg 101ms/call: # 6 times (466µs+606ms) by RBM::recursive_copy at line 758 of /root/tor-browser-build/rbm/lib/RBM.pm, avg 101ms/call
sub fcopy {
140636µs6558µs $samecheck->(@_) or return;
# spent 558µs making 6 calls to File::Copy::Recursive::__ANON__[File/Copy/Recursive.pm:84], avg 93µs/call
14165µs 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 }
157697µs6165µs my ( $volm, $path ) = File::Spec->splitpath( $_[1] );
# spent 165µs making 6 calls to File::Spec::Unix::splitpath, avg 28µs/call
158634µs612µs if ( $path && !-d $path ) {
# spent 12µs making 6 calls to File::Copy::Recursive::CORE:ftdir, avg 2µs/call
159 pathmk( File::Spec->catpath( $volm, $path, '' ), $NoFtlPth );
160 }
161674µs1218µs if ( -l $_[0] && $CopyLink ) {
# spent 10µs making 6 calls to File::Copy::Recursive::CORE:ftlink, avg 2µs/call # spent 8µs making 6 calls to File::Copy::Recursive::CORE:ftdir, avg 1µs/call
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 {
174623µs67µs return if -d $_[0]; # address File::Copy::copy() bug outlined in https://rt.perl.org/Public/Bug/Display.html?id=132866
# spent 7µs making 6 calls to File::Copy::Recursive::CORE:ftdir, avg 1µs/call
175646µs6605ms copy(@_) or return;
# spent 605ms making 6 calls to File::Copy::copy, avg 101ms/call
176
177670µs6127µs my @base_file = File::Spec->splitpath( $_[0] );
# spent 127µs making 6 calls to File::Spec::Unix::splitpath, avg 21µs/call
1786128µs6101µs my $mode_trg = -d $_[1] ? File::Spec->catfile( $_[1], $base_file[$#base_file] ) : $_[1];
# spent 101µs making 6 calls to File::Copy::Recursive::CORE:ftdir, avg 17µs/call
179
1806145µs1295µs chmod scalar( ( stat( $_[0] ) )[2] ), $mode_trg if $KeepMode;
# spent 58µs making 6 calls to File::Copy::Recursive::CORE:chmod, avg 10µs/call # spent 37µs making 6 calls to File::Copy::Recursive::CORE:stat, avg 6µs/call
181 }
182638µs 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 carp "Copying readonly directory ($org); mode of its contents may not be preserved.";
281 $rc = $recurs->( $org, $new, $buf ) if defined $buf;
282 $rc = $recurs->( $org, $new ) if !defined $buf;
283 chmod scalar( ( stat($org) )[2] ), $new;
284 }
285 else {
286 $rc = $recurs->( $org, $new, $buf ) if defined $buf;
287 $rc = $recurs->( $org, $new ) if !defined $buf;
288 }
289 if ( !$rc ) {
290 if ($SkipFlop) {
291 next;
292 }
293 else {
294 return;
295 }
296 }
297 $filen++;
298 $dirn++;
299 }
300 else {
301 if ( $ok_todo_asper_condcopy->($org) ) {
302 if ($SkipFlop) {
303 fcopy( $org, $new, $buf ) or next if defined $buf;
304 fcopy( $org, $new ) or next if !defined $buf;
305 }
306 else {
307 fcopy( $org, $new, $buf ) or return if defined $buf;
308 fcopy( $org, $new ) or return if !defined $buf;
309 }
310 chmod scalar( ( stat($org) )[2] ), $new if $KeepMode;
311 $filen++;
312 }
313 }
314 }
315 $level--;
316 chmod scalar( ( stat($str) )[2] ), $end if $KeepMode;
317 1;
318
319 };
320
321 $recurs->( $_zero, $_one, $_[2] ) or return;
322 return wantarray ? ( $filen, $dirn, $level ) : $filen;
323}
324
325sub fmove { $move->( 1, @_ ) }
326
327sub rmove {
328 if ( -l $_[0] && $CopyLink ) {
329 goto &fmove;
330 }
331
332 goto &dirmove if -d $_[0] || substr( $_[0], ( 1 * -1 ), 1 ) eq '*';
333 goto &fmove;
334}
335
336sub rmove_glob {
337 $glob->( \&rmove, @_ );
338}
339
340sub dirmove { $move->( 0, @_ ) }
341
342sub pathmk {
343 my ( $vol, $dir, $file ) = File::Spec->splitpath( shift() );
344 my $nofatal = shift;
345
346 $DirPerms = oct($DirPerms) if substr( $DirPerms, 0, 1 ) eq '0';
347
348 if ( defined($dir) ) {
349 my (@dirs) = File::Spec->splitdir($dir);
350
351 for ( my $i = 0; $i < scalar(@dirs); $i++ ) {
352 my $newdir = File::Spec->catdir( @dirs[ 0 .. $i ] );
353 my $newpth = File::Spec->catpath( $vol, $newdir, "" );
354
355 mkdir( $newpth, $DirPerms ) or return if !-d $newpth && !$nofatal;
356 mkdir( $newpth, $DirPerms ) if !-d $newpth && $nofatal;
357 }
358 }
359
360 if ( defined($file) ) {
361 my $newpth = File::Spec->catpath( $vol, $dir, $file );
362
363 mkdir( $newpth, $DirPerms ) or return if !-d $newpth && !$nofatal;
364 mkdir( $newpth, $DirPerms ) if !-d $newpth && $nofatal;
365 }
366
367 1;
368}
369
370sub pathempty {
371 my $pth = shift;
372
373 my ( $orig_dev, $orig_ino ) = ( lstat $pth )[ 0, 1 ];
374 return 2 if !-d _ || !$orig_dev || ( $^O ne 'MSWin32' && !$orig_ino ); #stat.inode is 0 on Windows
375
376 my $starting_point = Cwd::cwd();
377 my ( $starting_dev, $starting_ino ) = ( lstat $starting_point )[ 0, 1 ];
378 chdir($pth) or Carp::croak("Failed to change directory to “$pth”: $!");
379 $pth = '.';
380 _bail_if_changed( $pth, $orig_dev, $orig_ino );
381
382 my @names;
383 my $pth_dh;
384 if ( $] < 5.006 ) {
385 opendir( PTH_DH, $pth ) or return;
386 @names = grep !/^\.\.?$/, readdir(PTH_DH);
387 closedir PTH_DH;
388 }
389 else {
390 opendir( $pth_dh, $pth ) or return;
391 @names = grep !/^\.\.?$/, readdir($pth_dh);
392 closedir $pth_dh;
393 }
394 _bail_if_changed( $pth, $orig_dev, $orig_ino );
395
396 for my $name (@names) {
397 my ($name_ut) = $name =~ m{ (.*) }xms;
398 my $flpth = File::Spec->catdir( $pth, $name_ut );
399
400 if ( -l $flpth ) {
401 _bail_if_changed( $pth, $orig_dev, $orig_ino );
402 unlink $flpth or return;
403 }
404 elsif ( -d $flpth ) {
405 _bail_if_changed( $pth, $orig_dev, $orig_ino );
406 pathrmdir($flpth) or return;
407 }
408 else {
409 _bail_if_changed( $pth, $orig_dev, $orig_ino );
410 unlink $flpth or return;
411 }
412 }
413
414 chdir($starting_point) or Carp::croak("Failed to change directory to “$starting_point”: $!");
415 _bail_if_changed( ".", $starting_dev, $starting_ino );
416
417 return 1;
418}
419
420sub pathrm {
421 my ( $path, $force, $nofail ) = @_;
422
423 my ( $orig_dev, $orig_ino ) = ( lstat $path )[ 0, 1 ];
424 return 2 if !-d _ || !$orig_dev || !$orig_ino;
425
426 # Manual test (I hate this function :/):
427 # sudo mkdir /foo && perl -MFile::Copy::Recursive=pathrm -le 'print pathrm("/foo",1)' && sudo rm -rf /foo
428 if ( $force && File::Spec->file_name_is_absolute($path) ) {
429 Carp::croak("pathrm() w/ force on abspath is not allowed");
430 }
431
432 my @pth = File::Spec->splitdir($path);
433
434 my %fs_check;
435 my $aggregate_path;
436 for my $part (@pth) {
437 $aggregate_path = defined $aggregate_path ? File::Spec->catdir( $aggregate_path, $part ) : $part;
438 $fs_check{$aggregate_path} = [ ( lstat $aggregate_path )[ 0, 1 ] ];
439 }
440
441 while (@pth) {
442 my $cur = File::Spec->catdir(@pth);
443 last if !$cur; # necessary ???
444
445 if ($force) {
446 _bail_if_changed( $cur, $fs_check{$cur}->[0], $fs_check{$cur}->[1] );
447 if ( !pathempty($cur) ) {
448 return unless $nofail;
449 }
450 }
451 _bail_if_changed( $cur, $fs_check{$cur}->[0], $fs_check{$cur}->[1] );
452 if ($nofail) {
453 rmdir $cur;
454 }
455 else {
456 rmdir $cur or return;
457 }
458 pop @pth;
459 }
460
461 return 1;
462}
463
464sub pathrmdir {
465 my $dir = shift;
466 if ( -e $dir ) {
467 return if !-d $dir;
468 }
469 else {
470 return 2;
471 }
472
473 my ( $orig_dev, $orig_ino ) = ( lstat $dir )[ 0, 1 ];
474 return 2 if !$orig_dev || ( $^O ne 'MSWin32' && !$orig_ino );
475
476 pathempty($dir) or return;
477 _bail_if_changed( $dir, $orig_dev, $orig_ino );
478 rmdir $dir or return;
479
480 return 1;
481}
482
483sub _bail_if_changed {
484 my ( $path, $orig_dev, $orig_ino ) = @_;
485
486 my ( $cur_dev, $cur_ino ) = ( lstat $path )[ 0, 1 ];
487
488 if ( !defined $cur_dev || !defined $cur_ino ) {
489 $cur_dev ||= "undef(path went away?)";
490 $cur_ino ||= "undef(path went away?)";
491 }
492 else {
493 $path = Cwd::abs_path($path);
494 }
495
496 if ( $orig_dev ne $cur_dev || $orig_ino ne $cur_ino ) {
497 local $Carp::CarpLevel += 1;
498 Carp::croak("directory $path changed: expected dev=$orig_dev ino=$orig_ino, actual dev=$cur_dev ino=$cur_ino, aborting");
499 }
500}
501
502111µs1;
503
504__END__
 
# spent 58µs within File::Copy::Recursive::CORE:chmod which was called 6 times, avg 10µs/call: # 6 times (58µs+0s) by File::Copy::Recursive::fcopy at line 180, avg 10µs/call
sub File::Copy::Recursive::CORE:chmod; # opcode
# spent 139µs within File::Copy::Recursive::CORE:ftdir which was called 30 times, avg 5µs/call: # 6 times (101µs+0s) by File::Copy::Recursive::fcopy at line 178, avg 17µs/call # 6 times (12µs+0s) by File::Copy::Recursive::fcopy at line 158, avg 2µs/call # 6 times (10µs+0s) by File::Copy::Recursive::__ANON__[/usr/share/perl5/File/Copy/Recursive.pm:84] at line 59, avg 2µs/call # 6 times (8µs+0s) by File::Copy::Recursive::fcopy at line 161, avg 1µs/call # 6 times (7µs+0s) by File::Copy::Recursive::fcopy at line 174, avg 1µs/call
sub File::Copy::Recursive::CORE:ftdir; # opcode
# spent 10µs within File::Copy::Recursive::CORE:ftlink which was called 6 times, avg 2µs/call: # 6 times (10µs+0s) by File::Copy::Recursive::fcopy at line 161, avg 2µs/call
sub File::Copy::Recursive::CORE:ftlink; # opcode
# spent 166µs within File::Copy::Recursive::CORE:stat which was called 18 times, avg 9µs/call: # 6 times (109µs+0s) by File::Copy::Recursive::__ANON__[/usr/share/perl5/File/Copy/Recursive.pm:84] at line 52, avg 18µs/call # 6 times (37µs+0s) by File::Copy::Recursive::fcopy at line 180, avg 6µs/call # 6 times (19µs+0s) by File::Copy::Recursive::__ANON__[/usr/share/perl5/File/Copy/Recursive.pm:84] at line 51, avg 3µs/call
sub File::Copy::Recursive::CORE:stat; # opcode
# spent 11µs within File::Copy::Recursive::CORE:symlink which was called: # once (11µs+0s) by RBM::BEGIN@15 at line 31
sub File::Copy::Recursive::CORE:symlink; # opcode
# spent 600ns within File::Copy::Recursive::__ANON__ which was called: # once (600ns+0s) by File::Copy::Recursive::BEGIN@13 at line 13
sub File::Copy::Recursive::__ANON__; # xsub
Report produced by the NYTProf 6.06 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.