view release on metacpan or  search on metacpan

inc/File/Copy/Recursive.pm  view on Meta::CPAN

   }
   if(@x) {
      if($fl) {
         unlink $_[0] or return;
      } else {
         pathrmdir($_[0]) or return;
      }
      if($RemvBase) {
         my ($volm, $path) = File::Spec->splitpath($_[0]);
         pathrm(File::Spec->catpath($volm,$path,''), $ForcePth, $NoFtlPth) or return;
      }
   }
  return wantarray ? @x : $x[0];
};

my $ok_todo_asper_condcopy = sub {
    my $org = shift;
    my $copy = 1;
    if(exists $CondCopy->{$org}) {
        if($CondCopy->{$org}{'md5'}) {

        }
        if($copy) {

        }
    }
    return $copy;
};

sub fcopy { 
   $samecheck->(@_) or return;
   if($RMTrgFil && (-d $_[1] || -e $_[1]) ) {
      my $trg = $_[1];
      if( -d $trg ) {
        my @trgx = File::Spec->splitpath( $_[0] );
        $trg = File::Spec->catfile( $_[1], $trgx[ $#trgx ] );
      }
      $samecheck->($_[0], $trg) or return;
      if(-e $trg) {
         if($RMTrgFil == 1) {
            unlink $trg or carp "\$RMTrgFil failed: $!";
         } else {
            unlink $trg or return;
         }
      }
   }
   my ($volm, $path) = File::Spec->splitpath($_[1]);
   if($path && !-d $path) {
      pathmk(File::Spec->catpath($volm,$path,''), $NoFtlPth);
   }
   if( -l $_[0] && $CopyLink ) {
      carp "Copying a symlink ($_[0]) whose target does not exist" 
          if !-e readlink($_[0]) && $BdTrgWrn;
      symlink readlink(shift()), shift() or return;
   } else {  
      copy(@_) or return;

      my @base_file = File::Spec->splitpath($_[0]);
      my $mode_trg = -d $_[1] ? File::Spec->catfile($_[1], $base_file[ $#base_file ]) : $_[1];

      chmod scalar((stat($_[0]))[2]), $mode_trg if $KeepMode;
   }
   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
}

sub rcopy { 
    if (-l $_[0] && $CopyLink) {
        goto &fcopy;    
    }
    
    goto &dircopy if -d $_[0] || substr( $_[0], ( 1 * -1), 1) eq '*';
    goto &fcopy;
}

sub rcopy_glob {
    $glob->(\&rcopy, @_);
}

sub dircopy {
   if($RMTrgDir && -d $_[1]) {
      if($RMTrgDir == 1) {
         pathrmdir($_[1]) or carp "\$RMTrgDir failed: $!";
      } else {
         pathrmdir($_[1]) or return;
      }
   }
   my $globstar = 0;
   my $_zero = $_[0];
   my $_one = $_[1];
   if ( substr( $_zero, ( 1 * -1 ), 1 ) eq '*') {
       $globstar = 1;
       $_zero = substr( $_zero, 0, ( length( $_zero ) - 1 ) );
   }

   $samecheck->(  $_zero, $_[1] ) or return;
   if ( !-d $_zero || ( -e $_[1] && !-d $_[1] ) ) {
       $! = 20; 
       return;
   } 

   if(!-d $_[1]) {
      pathmk($_[1], $NoFtlPth) or return;
   } else {
      if($CPRFComp && !$globstar) {
         my @parts = File::Spec->splitdir($_zero);
         while($parts[ $#parts ] eq '') { pop @parts; }
         $_one = File::Spec->catdir($_[1], $parts[$#parts]);
      }
   }
   my $baseend = $_one;
   my $level   = 0;
   my $filen   = 0;
   my $dirn    = 0;

   my $recurs; #must be my()ed before sub {} since it calls itself
   $recurs =  sub {
      my ($str,$end,$buf) = @_;
      $filen++ if $end eq $baseend; 
      $dirn++ if $end eq $baseend;
      
      $DirPerms = oct($DirPerms) if substr($DirPerms,0,1) eq '0';
      mkdir($end,$DirPerms) or return if !-d $end;
      chmod scalar((stat($str))[2]), $end if $KeepMode;
      if($MaxDepth && $MaxDepth =~ m/^\d+$/ && $level >= $MaxDepth) {
         return ($filen,$dirn,$level) if wantarray;
         return $filen;
      }
      $level++;

      
      my @files;
      if ( $] < 5.006 ) {
          opendir(STR_DH, $str) or return;
          @files = grep( $_ ne '.' && $_ ne '..', readdir(STR_DH));
          closedir STR_DH;
      }
      else {
          opendir(my $str_dh, $str) or return;
          @files = grep( $_ ne '.' && $_ ne '..', readdir($str_dh));
          closedir $str_dh;
      }

      for my $file (@files) {
          my ($file_ut) = $file =~ m{ (.*) }xms;
          my $org = File::Spec->catfile($str, $file_ut);
          my $new = File::Spec->catfile($end, $file_ut);
          if( -l $org && $CopyLink ) {
              carp "Copying a symlink ($org) whose target does not exist" 
                  if !-e readlink($org) && $BdTrgWrn;
              symlink readlink($org), $new or return;
          } 
          elsif(-d $org) {
              $recurs->($org,$new,$buf) if defined $buf;
              $recurs->($org,$new) if !defined $buf;
              $filen++;
              $dirn++;
          } 
          else {
              if($ok_todo_asper_condcopy->($org)) {
                  if($SkipFlop) {
                      fcopy($org,$new,$buf) or next if defined $buf;
                      fcopy($org,$new) or next if !defined $buf;                      
                  }
                  else {
                      fcopy($org,$new,$buf) or return if defined $buf;
                      fcopy($org,$new) or return if !defined $buf;
                  }
                  chmod scalar((stat($org))[2]), $new if $KeepMode;
                  $filen++;
              }
          }
      }
      1;
   };

   $recurs->($_zero, $_one, $_[2]) or return;
   return wantarray ? ($filen,$dirn,$level) : $filen;
}

sub fmove { $move->(1, @_) } 

sub rmove { 
    if (-l $_[0] && $CopyLink) {
        goto &fmove;    
    }
    
    goto &dirmove if -d $_[0] || substr( $_[0], ( 1 * -1), 1) eq '*';
    goto &fmove;
}

sub rmove_glob {
    $glob->(\&rmove, @_);
}

sub dirmove { $move->(0, @_) }

sub pathmk {
   my @parts = File::Spec->splitdir( shift() );
   my $nofatal = shift;
   my $pth = $parts[0];
   my $zer = 0;
   if(!$pth) {
      $pth = File::Spec->catdir($parts[0],$parts[1]);
      $zer = 1;
   }
   for($zer..$#parts) {
      $DirPerms = oct($DirPerms) if substr($DirPerms,0,1) eq '0';
      mkdir($pth,$DirPerms) or return if !-d $pth && !$nofatal;
      mkdir($pth,$DirPerms) if !-d $pth && $nofatal;
      $pth = File::Spec->catdir($pth, $parts[$_ + 1]) unless $_ == $#parts;
   }
   1;
} 

sub pathempty {
   my $pth = shift; 

   return 2 if !-d $pth;

   my @names;
   my $pth_dh;
   if ( $] < 5.006 ) {
       opendir(PTH_DH, $pth) or return;
       @names = grep !/^\.+$/, readdir(PTH_DH);
   }
   else {
       opendir($pth_dh, $pth) or return;
       @names = grep !/^\.+$/, readdir($pth_dh);