2 package File::Copy::Recursive;
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;
13 use File::Spec; #not really needed because File::Copy already gets it, but for good measure :)
16 @ISA @EXPORT_OK $VERSION $MaxDepth $KeepMode $CPRFComp $CopyLink
17 $PFSCheck $RemvBase $NoFtlPth $ForcePth $CopyLoop $RMTrgFil $RMTrgDir
18 $CondCopy $BdTrgWrn $SkipFlop $DirPerms
23 @EXPORT_OK = qw(fcopy rcopy dircopy fmove rmove dirmove pathmk pathrm pathempty pathrmdir);
29 $CopyLink = eval { local $SIG{'__DIE__'};symlink '',''; 1 } || 0;
43 return 1 if $^O eq 'MSWin32'; # need better way to check for this on winders...
44 return if @_ != 2 || !defined $_[0] || !defined $_[1];
45 return if $_[0] eq $_[1];
49 $one = join( '-', ( stat $_[0] )[0,1] ) || '';
50 my $two = join( '-', ( stat $_[1] )[0,1] ) || '';
51 if ( $one eq $two && $one ) {
52 carp "$_[0] and $_[1] are identical";
57 if(-d $_[0] && !$CopyLoop) {
58 $one = join( '-', ( stat $_[0] )[0,1] ) if !$one;
59 my $abs = File::Spec->rel2abs($_[1]);
60 my @pth = File::Spec->splitdir( $abs );
62 my $cur = File::Spec->catdir(@pth);
63 last if !$cur; # probably not necessary, but nice to have just in case :)
64 my $two = join( '-', ( stat $cur )[0,1] ) || '';
65 if ( $one eq $two && $one ) {
66 # $! = 62; # Too many levels of symbolic links
67 carp "Caught Deep Recursion Condition: $_[0] contains $_[1]";
79 my ($do, $src_glob, @args) = @_;
84 for my $path ( glob($src_glob) ) {
85 my @call = [$do->($path, @args)] or return;
96 @x = fcopy(@_) or return;
98 @x = dircopy(@_) or return;
102 unlink $_[0] or return;
104 pathrmdir($_[0]) or return;
107 my ($volm, $path) = File::Spec->splitpath($_[0]);
108 pathrm(File::Spec->catpath($volm,$path,''), $ForcePth, $NoFtlPth) or return;
111 return wantarray ? @x : $x[0];
114 my $ok_todo_asper_condcopy = sub {
117 if(exists $CondCopy->{$org}) {
118 if($CondCopy->{$org}{'md5'}) {
129 $samecheck->(@_) or return;
130 if($RMTrgFil && (-d $_[1] || -e $_[1]) ) {
133 my @trgx = File::Spec->splitpath( $_[0] );
134 $trg = File::Spec->catfile( $_[1], $trgx[ $#trgx ] );
136 $samecheck->($_[0], $trg) or return;
139 unlink $trg or carp "\$RMTrgFil failed: $!";
141 unlink $trg or return;
145 my ($volm, $path) = File::Spec->splitpath($_[1]);
146 if($path && !-d $path) {
147 pathmk(File::Spec->catpath($volm,$path,''), $NoFtlPth);
149 if( -l $_[0] && $CopyLink ) {
150 carp "Copying a symlink ($_[0]) whose target does not exist"
151 if !-e readlink($_[0]) && $BdTrgWrn;
152 symlink readlink(shift()), shift() or return;
156 my @base_file = File::Spec->splitpath($_[0]);
157 my $mode_trg = -d $_[1] ? File::Spec->catfile($_[1], $base_file[ $#base_file ]) : $_[1];
159 chmod scalar((stat($_[0]))[2]), $mode_trg if $KeepMode;
161 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
165 if (-l $_[0] && $CopyLink) {
169 goto &dircopy if -d $_[0] || substr( $_[0], ( 1 * -1), 1) eq '*';
174 $glob->(\&rcopy, @_);
178 if($RMTrgDir && -d $_[1]) {
180 pathrmdir($_[1]) or carp "\$RMTrgDir failed: $!";
182 pathrmdir($_[1]) or return;
188 if ( substr( $_zero, ( 1 * -1 ), 1 ) eq '*') {
190 $_zero = substr( $_zero, 0, ( length( $_zero ) - 1 ) );
193 $samecheck->( $_zero, $_[1] ) or return;
194 if ( !-d $_zero || ( -e $_[1] && !-d $_[1] ) ) {
200 pathmk($_[1], $NoFtlPth) or return;
202 if($CPRFComp && !$globstar) {
203 my @parts = File::Spec->splitdir($_zero);
204 while($parts[ $#parts ] eq '') { pop @parts; }
205 $_one = File::Spec->catdir($_[1], $parts[$#parts]);
213 my $recurs; #must be my()ed before sub {} since it calls itself
215 my ($str,$end,$buf) = @_;
216 $filen++ if $end eq $baseend;
217 $dirn++ if $end eq $baseend;
219 $DirPerms = oct($DirPerms) if substr($DirPerms,0,1) eq '0';
220 mkdir($end,$DirPerms) or return if !-d $end;
221 chmod scalar((stat($str))[2]), $end if $KeepMode;
222 if($MaxDepth && $MaxDepth =~ m/^\d+$/ && $level >= $MaxDepth) {
223 return ($filen,$dirn,$level) if wantarray;
231 opendir(STR_DH, $str) or return;
232 @files = grep( $_ ne '.' && $_ ne '..', readdir(STR_DH));
236 opendir(my $str_dh, $str) or return;
237 @files = grep( $_ ne '.' && $_ ne '..', readdir($str_dh));
241 for my $file (@files) {
242 my ($file_ut) = $file =~ m{ (.*) }xms;
243 my $org = File::Spec->catfile($str, $file_ut);
244 my $new = File::Spec->catfile($end, $file_ut);
245 if( -l $org && $CopyLink ) {
246 carp "Copying a symlink ($org) whose target does not exist"
247 if !-e readlink($org) && $BdTrgWrn;
248 symlink readlink($org), $new or return;
251 $recurs->($org,$new,$buf) if defined $buf;
252 $recurs->($org,$new) if !defined $buf;
257 if($ok_todo_asper_condcopy->($org)) {
259 fcopy($org,$new,$buf) or next if defined $buf;
260 fcopy($org,$new) or next if !defined $buf;
263 fcopy($org,$new,$buf) or return if defined $buf;
264 fcopy($org,$new) or return if !defined $buf;
266 chmod scalar((stat($org))[2]), $new if $KeepMode;
274 $recurs->($_zero, $_one, $_[2]) or return;
275 return wantarray ? ($filen,$dirn,$level) : $filen;
278 sub fmove { $move->(1, @_) }
281 if (-l $_[0] && $CopyLink) {
285 goto &dirmove if -d $_[0] || substr( $_[0], ( 1 * -1), 1) eq '*';
290 $glob->(\&rmove, @_);
293 sub dirmove { $move->(0, @_) }
296 my @parts = File::Spec->splitdir( shift() );
301 $pth = File::Spec->catdir($parts[0],$parts[1]);
305 $DirPerms = oct($DirPerms) if substr($DirPerms,0,1) eq '0';
306 mkdir($pth,$DirPerms) or return if !-d $pth && !$nofatal;
307 mkdir($pth,$DirPerms) if !-d $pth && $nofatal;
308 $pth = File::Spec->catdir($pth, $parts[$_ + 1]) unless $_ == $#parts;
316 return 2 if !-d $pth;
321 opendir(PTH_DH, $pth) or return;
322 @names = grep !/^\.+$/, readdir(PTH_DH);
325 opendir($pth_dh, $pth) or return;
326 @names = grep !/^\.+$/, readdir($pth_dh);
329 for my $name (@names) {
330 my ($name_ut) = $name =~ m{ (.*) }xms;
331 my $flpth = File::Spec->catdir($pth, $name_ut);
334 unlink $flpth or return;
337 pathrmdir($flpth) or return;
340 unlink $flpth or return;
356 return 2 if !-d $path;
357 my @pth = File::Spec->splitdir( $path );
361 my $cur = File::Spec->catdir(@pth);
362 last if !$cur; # necessary ???
364 pathempty($cur) or return if $force;
365 rmdir $cur or return;
368 pathempty($cur) if $force;
385 pathempty($dir) or return;
387 rmdir $dir or return;