examples/THSelenium-Test/inc/File/Copy/Recursive.pm

   1 #line 1
   2 package File::Copy::Recursive;
   3
   4 use strict;
   5 BEGIN {
   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 }
   9 use warnings;
  10
  11 use Carp;
  12 use File::Copy;
  13 use File::Spec; #not really needed because File::Copy already gets it, but for good measure :)
  14
  15 use vars qw(
  16     @ISA      @EXPORT_OK $VERSION  $MaxDepth $KeepMode $CPRFComp $CopyLink
  17     $PFSCheck $RemvBase $NoFtlPth  $ForcePth $CopyLoop $RMTrgFil $RMTrgDir
  18     $CondCopy $BdTrgWrn $SkipFlop  $DirPerms
  19 );
  20
  21 require Exporter;
  22 @ISA = qw(Exporter);
  23 @EXPORT_OK = qw(fcopy rcopy dircopy fmove rmove dirmove pathmk pathrm pathempty pathrmdir);
  24 $VERSION = '0.38';
  25
  26 $MaxDepth = 0;
  27 $KeepMode = 1;
  28 $CPRFComp = 0;
  29 $CopyLink = eval { local $SIG{'__DIE__'};symlink '',''; 1 } || 0;
  30 $PFSCheck = 1;
  31 $RemvBase = 0;
  32 $NoFtlPth = 0;
  33 $ForcePth = 0;
  34 $CopyLoop = 0;
  35 $RMTrgFil = 0;
  36 $RMTrgDir = 0;
  37 $CondCopy = {};
  38 $BdTrgWrn = 0;
  39 $SkipFlop = 0;
  40 $DirPerms = 0777;
  41
  42 my $samecheck = sub {
  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];
  46
  47    my $one = '';
  48    if($PFSCheck) {
  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";
  53           return;
  54       }
  55    }
  56
  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 );
  61       while(@pth) {
  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]";
  68              return;
  69          }
  70
  71          pop @pth;
  72       }
  73    }
  74
  75    return 1;
  76 };
  77
  78 my $glob = sub {
  79     my ($do, $src_glob, @args) = @_;
  80
  81     local $CPRFComp = 1;
  82
  83     my @rt;
  84     for my $path ( glob($src_glob) ) {
  85         my @call = [$do->($path, @args)] or return;
  86         push @rt, \@call;
  87     }
  88
  89     return @rt;
  90 };
  91
  92 my $move = sub {
  93    my $fl = shift;
  94    my @x;
  95    if($fl) {
  96       @x = fcopy(@_) or return;
  97    } else {
  98       @x = dircopy(@_) or return;
  99    }
 100    if(@x) {
 101       if($fl) {
 102          unlink $_[0] or return;
 103       } else {
 104          pathrmdir($_[0]) or return;
 105       }
 106       if($RemvBase) {
 107          my ($volm, $path) = File::Spec->splitpath($_[0]);
 108          pathrm(File::Spec->catpath($volm,$path,''), $ForcePth, $NoFtlPth) or return;
 109       }
 110    }
 111   return wantarray ? @x : $x[0];
 112 };
 113
 114 my $ok_todo_asper_condcopy = sub {
 115     my $org = shift;
 116     my $copy = 1;
 117     if(exists $CondCopy->{$org}) {
 118         if($CondCopy->{$org}{'md5'}) {
 119
 120         }
 121         if($copy) {
 122
 123         }
 124     }
 125     return $copy;
 126 };
 127
 128 sub fcopy {
 129    $samecheck->(@_) or return;
 130    if($RMTrgFil && (-d $_[1] || -e $_[1]) ) {
 131       my $trg = $_[1];
 132       if( -d $trg ) {
 133         my @trgx = File::Spec->splitpath( $_[0] );
 134         $trg = File::Spec->catfile( $_[1], $trgx[ $#trgx ] );
 135       }
 136       $samecheck->($_[0], $trg) or return;
 137       if(-e $trg) {
 138          if($RMTrgFil == 1) {
 139             unlink $trg or carp "\$RMTrgFil failed: $!";
 140          } else {
 141             unlink $trg or return;
 142          }
 143       }
 144    }
 145    my ($volm, $path) = File::Spec->splitpath($_[1]);
 146    if($path && !-d $path) {
 147       pathmk(File::Spec->catpath($volm,$path,''), $NoFtlPth);
 148    }
 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;
 153    } else {
 154       copy(@_) or return;
 155
 156       my @base_file = File::Spec->splitpath($_[0]);
 157       my $mode_trg = -d $_[1] ? File::Spec->catfile($_[1], $base_file[ $#base_file ]) : $_[1];
 158
 159       chmod scalar((stat($_[0]))[2]), $mode_trg if $KeepMode;
 160    }
 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
 162 }
 163
 164 sub rcopy {
 165     if (-l $_[0] && $CopyLink) {
 166         goto &fcopy;
 167     }
 168
 169     goto &dircopy if -d $_[0] || substr( $_[0], ( 1 * -1), 1) eq '*';
 170     goto &fcopy;
 171 }
 172
 173 sub rcopy_glob {
 174     $glob->(\&rcopy, @_);
 175 }
 176
 177 sub dircopy {
 178    if($RMTrgDir && -d $_[1]) {
 179       if($RMTrgDir == 1) {
 180          pathrmdir($_[1]) or carp "\$RMTrgDir failed: $!";
 181       } else {
 182          pathrmdir($_[1]) or return;
 183       }
 184    }
 185    my $globstar = 0;
 186    my $_zero = $_[0];
 187    my $_one = $_[1];
 188    if ( substr( $_zero, ( 1 * -1 ), 1 ) eq '*') {
 189        $globstar = 1;
 190        $_zero = substr( $_zero, 0, ( length( $_zero ) - 1 ) );
 191    }
 192
 193    $samecheck->(  $_zero, $_[1] ) or return;
 194    if ( !-d $_zero || ( -e $_[1] && !-d $_[1] ) ) {
 195        $! = 20;
 196        return;
 197    }
 198
 199    if(!-d $_[1]) {
 200       pathmk($_[1], $NoFtlPth) or return;
 201    } else {
 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]);
 206       }
 207    }
 208    my $baseend = $_one;
 209    my $level   = 0;
 210    my $filen   = 0;
 211    my $dirn    = 0;
 212
 213    my $recurs; #must be my()ed before sub {} since it calls itself
 214    $recurs =  sub {
 215       my ($str,$end,$buf) = @_;
 216       $filen++ if $end eq $baseend;
 217       $dirn++ if $end eq $baseend;
 218
 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;
 224          return $filen;
 225       }
 226       $level++;
 227
 228
 229       my @files;
 230       if ( $] < 5.006 ) {
 231           opendir(STR_DH, $str) or return;
 232           @files = grep( $_ ne '.' && $_ ne '..', readdir(STR_DH));
 233           closedir STR_DH;
 234       }
 235       else {
 236           opendir(my $str_dh, $str) or return;
 237           @files = grep( $_ ne '.' && $_ ne '..', readdir($str_dh));
 238           closedir $str_dh;
 239       }
 240
 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;
 249           }
 250           elsif(-d $org) {
 251               $recurs->($org,$new,$buf) if defined $buf;
 252               $recurs->($org,$new) if !defined $buf;
 253               $filen++;
 254               $dirn++;
 255           }
 256           else {
 257               if($ok_todo_asper_condcopy->($org)) {
 258                   if($SkipFlop) {
 259                       fcopy($org,$new,$buf) or next if defined $buf;
 260                       fcopy($org,$new) or next if !defined $buf;
 261                   }
 262                   else {
 263                       fcopy($org,$new,$buf) or return if defined $buf;
 264                       fcopy($org,$new) or return if !defined $buf;
 265                   }
 266                   chmod scalar((stat($org))[2]), $new if $KeepMode;
 267                   $filen++;
 268               }
 269           }
 270       }
 271       1;
 272    };
 273
 274    $recurs->($_zero, $_one, $_[2]) or return;
 275    return wantarray ? ($filen,$dirn,$level) : $filen;
 276 }
 277
 278 sub fmove { $move->(1, @_) }
 279
 280 sub rmove {
 281     if (-l $_[0] && $CopyLink) {
 282         goto &fmove;
 283     }
 284
 285     goto &dirmove if -d $_[0] || substr( $_[0], ( 1 * -1), 1) eq '*';
 286     goto &fmove;
 287 }
 288
 289 sub rmove_glob {
 290     $glob->(\&rmove, @_);
 291 }
 292
 293 sub dirmove { $move->(0, @_) }
 294
 295 sub pathmk {
 296    my @parts = File::Spec->splitdir( shift() );
 297    my $nofatal = shift;
 298    my $pth = $parts[0];
 299    my $zer = 0;
 300    if(!$pth) {
 301       $pth = File::Spec->catdir($parts[0],$parts[1]);
 302       $zer = 1;
 303    }
 304    for($zer..$#parts) {
 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;
 309    }
 310    1;
 311 }
 312
 313 sub pathempty {
 314    my $pth = shift;
 315
 316    return 2 if !-d $pth;
 317
 318    my @names;
 319    my $pth_dh;
 320    if ( $] < 5.006 ) {
 321        opendir(PTH_DH, $pth) or return;
 322        @names = grep !/^\.+$/, readdir(PTH_DH);
 323    }
 324    else {
 325        opendir($pth_dh, $pth) or return;
 326        @names = grep !/^\.+$/, readdir($pth_dh);
 327    }
 328
 329    for my $name (@names) {
 330       my ($name_ut) = $name =~ m{ (.*) }xms;
 331       my $flpth     = File::Spec->catdir($pth, $name_ut);
 332
 333       if( -l $flpth ) {
 334               unlink $flpth or return;
 335       }
 336       elsif(-d $flpth) {
 337           pathrmdir($flpth) or return;
 338       }
 339       else {
 340           unlink $flpth or return;
 341       }
 342    }
 343
 344    if ( $] < 5.006 ) {
 345        closedir PTH_DH;
 346    }
 347    else {
 348        closedir $pth_dh;
 349    }
 350
 351    1;
 352 }
 353
 354 sub pathrm {
 355    my $path = shift;
 356    return 2 if !-d $path;
 357    my @pth = File::Spec->splitdir( $path );
 358    my $force = shift;
 359
 360    while(@pth) {
 361       my $cur = File::Spec->catdir(@pth);
 362       last if !$cur; # necessary ???
 363       if(!shift()) {
 364          pathempty($cur) or return if $force;
 365          rmdir $cur or return;
 366       }
 367       else {
 368          pathempty($cur) if $force;
 369          rmdir $cur;
 370       }
 371       pop @pth;
 372    }
 373    1;
 374 }
 375
 376 sub pathrmdir {
 377     my $dir = shift;
 378     if( -e $dir ) {
 379         return if !-d $dir;
 380     }
 381     else {
 382         return 2;
 383     }
 384
 385     pathempty($dir) or return;
 386
 387     rmdir $dir or return;
 388 }
 389
 390 1;
 391
 392 __END__
 393
 394 #line 696