File Coverage

blib/lib/File/Repl.pm

Criterion	Covered	Total	%
statement	281	491	57.2
branch	144	392	36.7
condition	14	72	19.4
subroutine	24	33	72.7
pod	7	13	53.8
total	470	1001	46.9

# File::Repl
#
# Version
#      $Source: C:/src/perl/File/Repl/RCS/Repl.pm $
#      $Revision: 2.3 $
#      $State: Exp $
#
# Start comments/code here - will not be processed into manual pages
#
#    Copyright © Dave Roberts  2000,2001
#
# Revision history:
#      $Log: Repl.pm $
#      Revision 2.3  2015/11/03 18:07:45  Dave.Roberts
#      interim release - corrections to help manage situations when a file and directory are compared
#
#      Revision 2.2  2015/11/01 22:36:38  Dave.Roberts
#      removed Win32::Admin requirement from documentation
#
#      Revision 2.1  2015/07/15 20:51:29  Dave.Roberts
#      added timestamp info for reading directories
#
#      Revision 2.0  2015/07/15 20:00:30  dave
#      New major version, now with Win32::AdminMisc depandency removed as this
#      module becomes more difficult to acquire and build for recent Perl releases
#
#      Revision 1.1  2015/07/15 19:58:06  Dave.Roberts
#      Initial revision
#
#      Revision 1.31  2014/01/25 21:27:59  Dave.Roberts
#      as advised from CPAN testing modified to include
#      =encoding utf8
#      and
#      escape the < and > characters in the pod with E and
#      E respectively.
#
#      Revision 1.29  2010/05/04 15:02:05  Dave.Roberts
#      corrected documentation - layout near Update method was incorrect
#
#      Revision 1.28  2010/04/27 14:55:00  Dave.Roberts
#      minor code improvements in output messages for the Delete method
#
#      Revision 1.27  2010/04/13 08:36:52  Dave.Roberts
#      added functionality for testing negative ages. This allows files older than the age
#      specified to be selected (excluding all files younger)
#
#      Revision 1.26  2010/04/12 16:29:57  Dave.Roberts
#      added Version method to return the File::Repl version
#      corrected silly mistake in documentation - in definition of %con hash
#
#      Revision 1.25  2010/04/12 16:04:54  Dave.Roberts
#      added example script for tombstoning
#      removed windows linefeed characters from file
#
#      Revision 1.24  2010/04/07 02:00:11  Dave.Roberts
#      modified code to remove the use of a hash as a reference - this was generating warnings
#      as this use of a hash has beeen depreciated.
#
#      Revision 1.21  2002/02/07 10:37:39  Dave.Roberts
#      corrected mode identified for Update method (the check used previously
#      was invalid), and also synopsis for use of Update method (args incorrectly
#      ordered)
#
#      Revision 1.20  2002/01/09 12:51:17  Dave.Roberts
#      corrected errors in tombstoning of directories - subs $del and
#      $deltree in particular
#
#      Revision 1.19  2001/11/21 21:28:19  Dave.Roberts
#      resolved error in determining file age, especially when the 'a' file is
#      missing
#      evaluated the current time at start (set $runtime), and then removed
#      many "time" calls
#
#      Revision 1.18  2001/08/22 07:10:41  Dave.Roberts
#      logic change so that we don't use the Win32::API on win9x machines
#
#      Revision 1.17  2001/08/03 09:38:29  Dave.Roberts
#      corrected code error (lines 572/3) where $$ was incorrectly used
#      corrected code error (lines 572/3) where $$ was incorrectly used in truncation code
#
#      Revision 1.16  2001/08/02 22:09:02  Dave.Roberts
#      corrected code for the Rename routine
#
#      Revision 1.15  2001/07/17 21:05:43  Dave.Roberts
#      small changes to _arraysort - simplifying code
#
#      Revision 1.14  2001/07/12 21:51:50  jj768
#      additional documentation - and minor code changes
#
#      Revision 1.13  2001/07/12 15:18:43  Dave.Roberts
#      code tidy up and reorganisation
#      fixed logic errors (A>B! mode in Update method was not copying new files from A to B), also for A
#      removed several local variables and used referred object directly
#
#      Revision 1.12  2001/07/11 10:30:16  Dave.Roberts
#      resolved various errors introduced in 1.11 - mainly associsated with reference errors
#      rehacked fc subroutine - to give more logical messages
#      still in need of more documentation - esp of object reference returned and associated variables
#
#      Revision 1.11  2001/07/06 14:52:53  jj768
#      double referencing of blessed object removed (from New method) and subsequent
#      methods updated. Requires Testing.
#      Update and other methods now return reference to data arrays and hashs evaluated
#      during method call
#
#      Revision 1.10  2001/07/06 08:23:48  Dave.Roberts
#      code changes to allow the colume info to be detected correctly using Win32::AdminMisc
#      when a drive letter is specified (was only working with UNC names)
#
#      Revision 1.9  2001/06/27 13:35:53  Dave.Roberts
#      minor presentation changes
#
#      Revision 1.8  2001/06/27 12:59:22  jj768
#      logic to prevent "Use of uninitialized value in pattern match (m//)" errors on use of $vol{FileSystemName}
#
#      Revision 1.6  2001/06/21 12:32:15  jj768
#      *** empty log message ***
#
#      Revision 1.5  2001/06/20 20:39:21  Dave.Roberts
#      minor header changes
#
#      Revision 1.4  2001/06/20 19:55:21  jj768
#      re-built module source files as per perlmodnew manpage
#
#
#******************************************************************************

package File::Repl;

require 5.005_62;
use strict;
use warnings;
use Carp;
use File::Find;
use File::Copy;
use File::Basename;
use constant FALSE                => 0;
use constant TRUE                 => 1;
use constant TIME_ZONE_ID_INVALID => 0xFFFFFFFF;

my($runtime) = time;


#**************************************************************
# On FAT filesystems, "stat" adds TZ_BIAS to the actual file
# times (atime, ctime and mtime) and "utime" subtracts TZ_BIAS
# from the supplied parameters before setting file times.  To
# maintain FAT at UTC time, we need to do the opposite.
#
# If we don't maintain FAT filesystems at UTC time and the repl
# is between FAT and NON-FAT systems, then all files will get
# replicated whenever the TZ or Daylight Savings Time changes.
#
# (NH270301)
#
my $TZ_BIAS = 0;               # global package variable
if ($^O eq 'MSWin32') {        # is this a win32 system ?
  if ( eval "use Win32" ) {
    my($string,$major,$minor,$build,$id) = Win32::GetOSVersion();
    if ( $id == 2 ) {   #  Machine is NT (0=Win32s, 1=Win9x etc)
      eval "use Win32::API";
      my $lpTimeZoneInformation = "\0" x 172;   # space for struct _TIME_ZONE_INFORMATION
      my $GetTimeZoneInformation = new Win32::API("kernel32", 'GetTimeZoneInformation', ['P'], 'N');
      croak "\n ERROR: failed to import GetTimeZoneInformation API function\n" if !$GetTimeZoneInformation;
      my $ISDST = $GetTimeZoneInformation->Call($lpTimeZoneInformation);
      croak "\n ERROR: GetTimeZoneInformation returned invalid data: " . Win32::FormatMessage(Win32::GetLastError())
      if $ISDST == TIME_ZONE_ID_INVALID;
      my ($Bias,$StandardBias,$DaylightBias) = unpack "l x80 l x80 l", $lpTimeZoneInformation;

# $ISDST == 0 -  No Daylight Savings in this timezone (no transition dates defined for this tz)
# $ISDST == 1 -  Standard time
# $ISDST == 2 -  Daylight Savings time

# bias times are returned in minutes - convert to seconds
      $TZ_BIAS = ($Bias + ($ISDST == 0 ? 0 : ($ISDST == 2 ? $DaylightBias : $StandardBias))) * 60;
    }
  }
}
#**************************************************************
require Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration		 use File::Repl ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw( ) ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw(

);

our $VERSION = sprintf("%d.%d", q$Revision: 2.3 $ =~ /(\d+)\.(\d+)/);

# Preloaded methods go here.
#---------------------------------------------------------------------
sub New {
  my $class = shift;
  my($conf) = $_[0];
  croak "\n Usage: File::Repl->New(\$hashref)\n\n" unless (ref($conf) eq "HASH");
  my($alist,$blist,$atype,$btype,$key,$xxx,$dira,$dirb,$tmp);
  $conf->{dira} =~ s/\\/\//g;     # Make dir use forward slash's
  $conf->{dirb} =~ s/\\/\//g;     # Make dir use forward slash's

# To maintain backwards compatibility, check if additional
# keys are defined and default to a suitable value (NH271100)
  my $r_con = {
    dira     => $conf->{dira},
    dirb     => $conf->{dirb},
    verbose  => (defined $conf->{verbose}) ? $conf->{verbose} : 0,       # default not verbose
    agelimit => (defined $conf->{age})     ? $conf->{age}     : 0,       # default 0 (don't check age)
    ttl      => (defined $conf->{ttl})     ? $conf->{ttl}     : 31,      # default ttl 31 days
    nocase   => (defined $conf->{nocase})  ? $conf->{nocase}  : TRUE,    # default nocase TRUE
    bmark    => (defined $conf->{bmark})   ? $conf->{bmark}   : FALSE,   # default benchmark FALSE
    recurse  => (defined $conf->{recurse}) ? $conf->{recurse} : TRUE,    # default recurse TRUE
    mkdirs   => (defined $conf->{mkdirs})  ? $conf->{mkdirs}  : FALSE,   # default mkdirs FALSE
  };

# Should we continue if dira / dirb dosn't exist ?  (NH301200)
  if ( $r_con->{verbose} >= 3 ) {
    printf "\n\nFile:Repl configuration settings:\n";
    printf "-------------------------------\n";
    foreach $key (keys %$r_con ) {
      printf "  Key %-10s   Value %-30s\n",$key, $r_con->{$key};
    }
  }

# Build the A list
  benchmark("init") if $r_con->{bmark};
  if ( -d $r_con->{dira} ) {
    printf "\treading dira %s\n",$r_con->{dira};
    my($start_dir) = time;
    if ($r_con->{recurse}) {
      $xxx = sub{
        ($tmp = $File::Find::name) =~ s/^\Q$r_con->{dira}//;        # Remove the start directory portion
        ($atype->{$tmp}, $alist->{$tmp}) = (stat($_))[2,9] if $tmp; # Mode is 3rd element, mtime is 10th
      };
      find(\&$xxx,$r_con->{dira});
      }else{
      opendir(DIRA, "$r_con->{dira}") || croak "Can not open $r_con->{dira} directory !!!\n";
      while($tmp = readdir(DIRA)) {
        $tmp = "/" . $tmp;
        next if -d $r_con->{dira} . $tmp;                           # Skip directories
        ($atype->{$tmp}, $alist->{$tmp}) = (stat($r_con->{dira} . $tmp))[2,9];
      }
      close DIRA;
    }
        printf "\tcompleted reading dira (%s sec)\n",&elapsed($start_dir);
    }elsif (!$r_con->{mkdirs}) {
    croak "Invalid directory name for dira ($r_con->{dira})\n";
  }
  benchmark("build A list") if $r_con->{bmark};

# Build the B list
  benchmark("init") if $r_con->{bmark};
  if ( $r_con->{dira} eq $r_con->{dirb} ) {
    $blist = $alist;
    $btype = $atype;
    }elsif ( -d $r_con->{dirb} ) {
       printf "\treading dirb %s\n",$r_con->{dirb};
    my($start_dir) = time;
    if ($r_con->{recurse}) {
      $xxx = sub{
        ($tmp = $File::Find::name) =~ s/^\Q$r_con->{dirb}//;        # Remove the start directory portion
        ($btype->{$tmp}, $blist->{$tmp}) = (stat($_))[2,9] if $tmp; # Mode is 3rd element, mtime is 10th
      };
      find(\&$xxx,$r_con->{dirb});
      }else{
      opendir(DIRB, "$r_con->{dirb}") || croak "Can not open $r_con->{dirb} directory !!!\n";
      while($tmp = readdir(DIRB)) {
        $tmp = "/" . $tmp;
        next if -d $r_con->{dirb} . $tmp;                           # Skip directories
        ($btype->{$tmp}, $blist->{$tmp}) = (stat($r_con->{dirb} . $tmp))[2,9];
      }
      close DIRB;
    }
        printf "\tcompleted reading dirb (%s sec)\n",&elapsed($start_dir);
    }elsif (!$r_con->{mkdirs}) {
    croak "Invalid directory name for dirb ($r_con->{dirb})\n";
  }
  benchmark("build B list") if $r_con->{bmark};
  $r_con->{alist} = $alist;
  $r_con->{atype} = $atype;
  $r_con->{blist} = $blist;
  $r_con->{btype} = $btype;
  bless  $r_con, $class;
  return $r_con;
}
#=====================================================================
sub Update {
  return _generic ("Update",@_);
}
#=====================================================================
sub Rename {
  return _generic ("Rename",@_);
}
#=====================================================================
sub Version {
  return $VERSION;
}
#=====================================================================
sub Process {
  if ( scalar(@_) eq 3 ) {
    my($r_con,$regex,$sub) =@_;
    my($negregex) = '^$';   # Make this impossible to match, nor file or directory
# can be of zero length name.
    }elsif ( scalar(@_) eq 4 ) {
    my($r_con,$regex,$negregex,$sub) =@_;
    }else{
    carp ("Try calling the File::Repl->Process method with the right arguments !\n");
  }
  print "The Process method is not implemented\n";
}
#=====================================================================
sub Compress {
  if ( scalar(@_) eq 3 ) {
    my($r_con,$regex,$archive) =@_;
    my($negregex) = '^$';   # Make this impossible to match, nor file or directory
# can be of zero length name.
    }elsif ( scalar(@_) eq 4 ) {
    my($r_con,$regex,$negregex,$mode,$commit) =@_;
    }else{
    carp ("Try calling the File::Repl->Compress method with the right arguments !\n");
  }
  print "The Compress method is not implemented\n";
}
#=====================================================================
sub Delete {
  return _generic ("Delete",@_);
}
#=====================================================================

sub _generic {
  my ($caller) = shift @_;
  my($r_con,$regex,$mode,$commit,$nsub);
  my($refa,$refb,$refatype,$refbtype,$agelimit,$verbose);
  my($name,$mtime,%mark,$afile,$bfile,$amtime,$bmtime,$fc,$md,$del,$type);
  my(@amatch,@bmatch,$benchmark,$tfiles,$common,$aonly,$bonly,$amatch,$bmatch,@temp,%vol);
  my($tName,$aName,$bName,$deltree,$truncate,$touch,$mv,$tmp,$atype,$btype);
  my ($negregex) = '^$';# Default value - make this impossible to match, neither file nor directory
  my $tz_bias_a = 0;
  my $tz_bias_b = 0;
  my $fudge = 2;  # Fudge factor to allow two machines to synch via a removeable drive/disc (A <> DOS <> B)

  if ($caller eq "Update") {
    if ( scalar(@_) == 4 ) {
      ($r_con,$regex,$mode,$commit) = @_;
    }elsif ( scalar(@_) == 5 ) {
      ($r_con,$regex,$negregex,$mode,$commit) = @_;
    }else{
      carp ("Call the Update method with the right arguments !\n\t\$ref->Update(regex, [noregex,] action, commit)");
      print scalar(@_), " Args called ( @_ )\n";
      return;
    }
    if ( $mode eq "" ) {      # Set the default operating mode
      $mode      = 'a>b';
      print "using default mode for Update method (a>b)\n" if ($verbose > 1);
    }
    if ( $mode !~ /^(A>B!?)|(A<>B)|(A]b)|(a<>b)$/ ) {
      carp("Illegal mode used for Update method - legal options are\n\tA>B\tA>B!\tAB\tab\ta<>b\n");
      return;
    }
  }elsif($caller eq "Delete"){
    if ( scalar(@_) eq 3 ) {
      ($r_con,$regex,$commit) =@_;
    }elsif ( scalar(@_) eq 4 ) {
      ($r_con,$regex,$negregex,$commit) =@_;
    }else{
      carp ("Call the Delete method with the right arguments !\n\t\$ref->Delete(regex, [noregex], commit)");
    }
  }elsif($caller eq "Rename"){
    if ( scalar(@_) eq 4 ) {
      ($r_con,$regex,$nsub,$commit) =@_;
    }elsif ( scalar(@_) eq 5 ) {
      ($r_con,$regex,$negregex,$nsub,$commit) =@_;
    }else{
      carp ("Call the Rename method with the right arguments !\n\t\$ref->Rename(regex, [noregex], namesub, commit)");
    }
  }

  my $ttl = $r_con->{ttl} * 86400;                               # Expiry time for tombstone indicator files in seconds
  $commit    = TRUE unless defined $commit;                      # Set default commit value
  $verbose   = $r_con->{verbose};
  $agelimit  = $r_con->{agelimit} ? $r_con->{agelimit} * 86400 : 0; # Determine age limit in seconds
  $negregex  = '^$' unless $negregex;                            # Ensure no matches if $negregex = ''


 # Fix for stat/utime on FAT filesystems (NH270301)
  if ($TZ_BIAS) {
    if ( ( $r_con->{dira} =~ /^([a-z]:)/i ) ||                   # First match a drive letter - ie D:
      ( $r_con->{dira} =~ /^([\\\/].\w+[\\\/][a-z0-9\$]+)/i ) ||   # Else match a share - ie //comp/share or \\comp\share
      ( Win32::GetCwd() =~ /^([a-z]:)/i ) ) {                      # Else assume relative path - use CWD
      $tz_bias_a = $TZ_BIAS if (FsType(1) =~ m/FAT/);
    }
    if ( ( $r_con->{dirb} =~ /^([a-z]:)/i ) ||                   # First match a drive letter - ie D:
      ( $r_con->{dirb} =~ /^([\\\/].\w+[\\\/][a-z0-9\$]+)/i ) ||   # Else match a share - ie //comp/share or \\comp\share
      ( Win32::GetCwd() =~ /^([a-z]:)/i ) ) {                      # Else assume relative path - use CWD
      $tz_bias_b = $TZ_BIAS if (FsType($1) =~ m/FAT/);
    }
    $tz_bias_a = $tz_bias_b = 0 if ($tz_bias_a && $tz_bias_b);
  }
if ($caller eq "Update") {
  print "Update
  Regex    : $regex
  NegRegex : $negregex
  Mode     : $mode
  Commit   : $commit
  AgeLimit : $r_con->{agelimit} days ($agelimit seconds)
  Tombstone File TTL : $ttl
  DirA DOS time adj  : $tz_bias_a
  DirB DOS time adj  : $tz_bias_b\n\n" if ($verbose >= 3);
}elsif ($caller eq "Delete"){
  print "Delete
  Regex    : $regex
  NegRegex : $negregex
  Commit   : $commit
  AgeLimit : $r_con->{agelimit} days ($agelimit seconds)
  Tombstone File TTL : $ttl
  DirA DOS time adj  : $tz_bias_a\n\n" if ($verbose >= 3);
}
# Sort files using regex and negregex
  benchmark("init") if $r_con->{bmark};
  ($tfiles,$common,$aonly,$bonly,$amatch,$bmatch) =
    _arraysort($r_con, $regex, $negregex, $r_con->{nocase}) ;
  benchmark("match files") if $r_con->{bmark};
  $refa     = $r_con->{alist};
  $refatype = $r_con->{atype};
  $refb     = $r_con->{blist};
  $refbtype = $r_con->{btype};
#****************************************************************
# sub to copy files and build directory structure
#****************************************************************
  $fc = sub {
    my($a,$b,$amtime,$bmtime,$disp,$mode) = @_;
    my($A,$B,$Amtime,$Bmtime,$Btmp,$age,$msg);
    print "fc ($a,$b,$amtime,$bmtime,$disp,$mode)\n" if $verbose > 3;
    if ( $disp eq "-->" ) {
      $A = $a;
      $B = $b;
      $Amtime = $amtime;
      $Bmtime = $bmtime;
    }elsif( $disp eq "<--" ) {
      $A = $b;
      $B = $a;
      $Amtime = $bmtime;
      $Bmtime = $amtime;
    }else{
      print "Illegal display option called ($disp)\n";
      return 0;
    }
    # so we are always copying A to B
    $msg = " $a $disp $b";
    if ( $amtime == 0 ) {
      $age = $bmtime;
    }elsif ( $bmtime == 0 ) {
      $age = $amtime;
    }else{
      ($bmtime > $amtime) ? $age = $bmtime : $age = $amtime; # Find the most recent mtime ($age)
    }
	if ( $agelimit ){
	   if ($agelimit > 0) {   # if $agelimit is positive - ignore files older than the agelimit
          if ( ( $runtime - $age ) > $agelimit ) { # Test for agelimit exceeded
            #print "amtime $amtime\nbmtime $bmtime\nage    $age\n";
            printf "%s - exceeds age limit (%3.1d days old - limit is set to less than %3d days)\n",$msg,(time - $age)/86400,$agelimit/86400 if ($verbose > 1);
            return FALSE;
          }
	   }else{                 # agelimit is negative - ignore files newer than the agelimit
          if ( ( $runtime - $age ) > -$agelimit ) { # Test for agelimit exceeded
            #print "amtime $amtime\nbmtime $bmtime\nage    $age\n";
            printf "%s - is less than the minimum age limit (%3.1d days old - limit is set to greater than %3d days)\n",$msg,(time - $age)/86400,-$agelimit/86400 if ($verbose > 1);
            return FALSE;
          }
	   }
    }
    if ( ! $commit ) {
      print "$msg\n"  if ($verbose >= 1);
      return TRUE;
    }
    unless (&$md(dirname($B))){ # Make sure the parent of the target file exists
       print "parent of target $B does not exist\n";
       printf "( %s )\n",dirname($B);
       return FALSE;
     }
    if ( -f $A ) {
      if ( -f $B ) {  # create a backup copy of target file $B
        $Btmp = $B . '.X';
        while ( -f $Btmp ) {  #  Find a temporary file name to copy target to (allows rollback after a copy failure)
          $Btmp .= 'X';
          print " *************** $Btmp\n";  # kind of error - this temp filename is already in use...
        }
        unless ( rename ($B, $Btmp) ) { # rename old copy of $B to $Btmp - to restore if the copy fails
          carp "Unable to create temp copy of $B ($Btmp) \n";  # carp if this fails - but continue.....
          undef $Btmp;
        }
      }
      if ( -d $B ){ # if the target file is a directory.... then remove it
        print " *************** removing directory tree $B to allow file copy\n";
        &deltree2($B);
        }

      if ( copy ($A,$B) ) {
        print "$msg\n"  if ($verbose >= 1);
# ******
# this needs modifying for UNIX
        chmod(0666,$B) if !($mode & 0x02);
        utime($Amtime,$Amtime,$B) || carp "Failed to set modification time on $B\n";
        chmod(0444,$B) if !($mode & 0x02);
# ******
        if ( $Btmp ) {  # remove the temporary file created
          unlink $Btmp || carp "Failed to delete temporary file $Btmp\n";
        }
        return TRUE;
      }else{
        carp "$msg - failed to copy $A\n";
        if ( $Btmp ) {
          unless ( rename ($Btmp, $B) ) {  # restore the temporary file after a copy failure
            carp "Unable to restore $B from temp copy of $Btmp following failed file copy\n";
            undef $Btmp;
          }
        }
      }
      }else{ # $A is a directory...
        if ( -f $B ){
        # if the target is a file - and needs to be a directory.... then remove it
        print " *************** removing file $B to allow replacement as a directory\n";
       unlink $B || carp "Failed to delete file $B\n";
        }
        if ( ! -d $B ) {

        mkdir($B,0777) && return TRUE || carp "Unable to create directory $B\n";
        print "$msg - (new directory)\n"  if ($verbose >= 1);
      }
#  setting utime doe'nt work on a dir.  Maybe FS rules ??
    }
    return FALSE;
  };

#****************************************************************
# sub to test a directory tree exists, and if not to create it
#****************************************************************
  $md = sub {
    my($Dir) = @_;
    return TRUE unless $commit;
    if (! -d $Dir) {
      $Dir =~ /(.*)\/([^\/]*)/;
      my($parent,$dir) = ($1,$2);
      &$md($parent) if (!-d $parent);  # Create the parent if it does not exist
      mkdir ($Dir, 0777) || carp "Unable to create directory $Dir\n";
    }
    return(-d $Dir);
  };

#****************************************************************
# sub to delete directories / files
#****************************************************************
 $del = sub {
    my($targ, $mtime) = @_;
    #print "del ($targ,$mtime)\n" if $verbose > 3;
    my($msg);
    if (-d $targ) {
      $msg = "  rmdir  $targ";
    }elsif (-f $targ) {
      $msg = "  rm $targ";
    }
    if ( $mtime && $agelimit ) {
	   if ( $agelimit > 0) {  # if $agelimit is positive - ignore files older than the agelimit
          if ( ( $runtime - $mtime ) > $agelimit ) {
            printf "%s - exceeds age limit (%3.1d days - limit is newer than %3.1d days))\n", $msg, (time - $mtime)/(86400), $agelimit/(86400) if ( $verbose > 1 );
            return FALSE;
          }
       }else{ #  if $agelimit is negative - ignore files newer than the agelimit
          if ( ( $runtime - $mtime ) < -$agelimit ) {
            printf "%s - under age limit (%3.1d days - limit is older than %3.1d days))\n", $msg, (time - $mtime)/(86400), -$agelimit/(86400) if ( $verbose > 1 );
            return FALSE;
          }
       }
    }else{
      print "$msg\n" if (($commit eq 0) & ($verbose >= 1));
    }
  return TRUE unless $commit;
  print "$msg\n";
  if (-d $targ) {
    rmdir $targ || carp "Unable to delete directory $targ\n";
    return ! -d $targ;
  }elsif (-f $targ) {
    unlink $targ || carp "Unable to delete file $targ\n";
    return ! -f $targ;
  }else{
    print "** DO SOMETHING HERE ** (NOT ORDINARY FILE OR DIRECTORY)\n";
  }
  return FALSE;
};

#****************************************************************
# sub to delete directory trees
# $targ    directory name
# $dir     path to directory
# $reftime reference to time hash (to allow record deletion)
# $reftype reference to type hash (to allow record deletion)
# $top      set true to remove top level directory
#****************************************************************
$deltree = sub {
  my($targ,$dir,$reftime,$reftype,$top) = @_;

  my $xxx = sub {
    ($tmp = $File::Find::name) =~ s/^\Q$dir//; # identify relative filename (to $dir)
    return if ($tmp eq $targ);                 # Don't remove top level directory unless $top == TRUE
    if (&$del($File::Find::name)) {
      delete $reftime->{$tmp};
      delete $reftype->{$tmp};
    }
  };
  finddepth(\&$xxx, $dir . $targ);
  if ($top) {
    chdir $dir;
    if (rmdir "$dir$targ") {
      delete $reftime->{$targ};
      delete $reftype->{$targ};
    }else{
		   print "failed to rmdir $dir$targ\n";
    }
  }else{
    $commit ? $$reftime->{$targ} = (stat($dir . $targ))[9] : $$reftime->{$targ} = $runtime;
  }
};

#****************************************************************
# sub to truncate files to zero length
#****************************************************************
$truncate = sub {
  my($file_ref, $mtime_ref) = @_;
  print " truncate $$file_ref\n" if ($verbose >= 2);
  if ($commit) {
    chmod(0666,$$file_ref)  || carp "Failed to chmod 0666 $$file_ref\n";
    truncate($$file_ref, 0) || carp "Failed to truncate $$file_ref\n";
  }
  $$mtime_ref = $commit ? (stat($$file_ref))[9] : $runtime;
  $$file_ref = undef;
  return TRUE;
};

#****************************************************************
# sub to touch files
#****************************************************************
$touch = sub {
  my($file, $mtime_ref, $type_ref) = @_;
  print "   touch $file\n" if ($verbose >= 2);
  if ($commit) {
    open(FILE, ">> $file") || carp "Failed to touch $file\n";
    close(FILE);
    chmod (0666,$file);
  }
  ($$type_ref, $$mtime_ref) = $commit ? (stat($file))[2,9] : $runtime;
};
#****************************************************************
# sub to rename a file or directory
#****************************************************************
$mv = sub {
  my($old,$new) = @_;
  my($msg) = "mv $old $new";
  unless ($commit) {
    print "$msg\n" if ($verbose > 1);
    return TRUE;
  }elsif ( rename ($old,$new)) {
    print "$msg\n" if ($verbose > 1);
    return TRUE;
  }else{
    print "$msg - Failed \n";
    return FALSE;
  }
};

benchmark("init") if $r_con->{bmark};
if ( $caller eq "Update" ) {
#****************************************************************
# Delete tombstoned files (NH261100)
#****************************************************************
  foreach $tName (@$tfiles) {
    ($name = $tName) =~ s/.remove$//i;

# Delete  trees and touch a file with same name
    if (-d $r_con->{dira} . $tName) {
      &$deltree($tName, $r_con->{dira}, $refa, $refatype, TRUE);
      &$touch($r_con->{dira} . $tName, \$refa->{$tName}, $refatype->{$tName});
    }
    if (-d $r_con->{dirb} . $tName) {
      &$deltree($tName, $r_con->{dirb}, $refb, $refbtype, TRUE);
      &$touch($r_con->{dirb} . $tName, \$refb->{$tName}, $refbtype->{$tName});
    }

# Delete  trees and files
    if ($r_con->{nocase}) {
      ($aName) = grep { /^$name$/i } (keys %$refa);
      ($bName) = grep { /^$name$/i } (keys %$refb);
      }else{
      $aName = ($refa->{$name}) ? $name : undef;
      $bName = ($refb->{$name}) ? $name : undef;
    }
    if ($aName) {
      if (-d $r_con->{dira} . $aName) {
# Delete dir trees including top level dir
        &$deltree($aName, $r_con->{dira}, $refa, $refatype, TRUE);
        }else{
        delete $refa->{$aName}, delete $refatype->{$aName} if &$del($r_con->{dira} . $aName);
      }
    }
    if ($bName) {
      if (-d $r_con->{dirb} . $bName) {
# Delete dir trees including top level dir
        &$deltree($bName, $r_con->{dirb}, $refb, $refbtype, TRUE);
        }else{
        delete $refb->{$bName}, delete $refbtype->{$bName} if &$del($r_con->{dirb} . $bName);
      }
    }
  }
#****************************************************************
# Remove tombstone indicator files if older than $ttl (NH261100)
# Truncate (which will also touch) nonzero byte files (NH070401)
#****************************************************************
  foreach (@$tfiles) {
    $afile = $refa->{$_} ? $r_con->{dira} . $_ : undef;
    $bfile = $refb->{$_} ? $r_con->{dirb} . $_ : undef;
    &$truncate(\$afile, \$refa->{$_}) if ($afile && -s $afile);
    &$truncate(\$bfile, \$refb->{$_}) if ($bfile && -s $bfile);
    delete $refa->{$_}, delete $refatype->{$_} if ($afile && (($refa->{$_} + $ttl) < $runtime) && &$del($afile));
    delete $refb->{$_}, delete $refbtype->{$_} if ($bfile && (($refb->{$_} + $ttl) < $runtime) && &$del($bfile));
  }
  # Note: modify arrays etc even if $commit is not set.  This is required to determine behaviour of code
  # without changing or deleting files and directories.
  if ( $mode =~ /^(A>B!?)|(A<>B)$/ ) {
    foreach (@$aonly) {
      next unless exists $refa->{$_};
      $afile  = $r_con->{dira} . $_;
      $amtime = $refa->{$_} - $tz_bias_a + $tz_bias_b;
      $atype  = $refatype->{$_};
      $bfile  = $r_con->{dirb} . $_;
      #print " $afile --> $bfile\n" if ($verbose >= 1);
      $refb->{$_} = $amtime, $refbtype->{$_} = $refatype->{$_} if &$fc($afile,$bfile,$amtime,0,"-->",$atype);
    }
  }
  if ( $mode =~ /^(AB)$/ ) {
    foreach (@$bonly) {
      next unless exists $refb->{$_};
      $afile  = $r_con->{dira} . $_;
      $bfile  = $r_con->{dirb} . $_;
      $bmtime = $refb->{$_} - $tz_bias_b + $tz_bias_a;
      $btype  = $refbtype->{$_};
      #print " $afile <-- $bfile\n" if ($verbose >= 1);
      $refa->{$_} = $bmtime, $refatype->{$_} = $refbtype->{$_} if &$fc($afile,$bfile,0,$bmtime,"<--",$btype);
    }
  }
  if ( $mode =~ /^A
    foreach (@$aonly) {
      next unless exists $refa->{$_};
      $afile  = $r_con->{dira} . $_;
      $amtime = $refa->{$_};
      delete $refa->{$_}, delete $refatype->{$_} if &$del($afile, $amtime);
    }
  }
  if ( $mode =~ /^A>B!$/ ) {
    foreach (@$bonly) {
      next unless exists $refb->{$_};
      $bfile  = $r_con->{dirb} . $_;
      $bmtime = $refb->{$_};
      delete $refb->{$_}, delete $refbtype->{$_} if &$del($bfile, $bmtime);
    }
  }

  foreach $aName (keys %$common) {
#    print "aName $aName\n";
#    printf "Ref: %s\n",$refa->{$aName};
    next unless exists $refa->{$aName};
# To allow for non case sensitive filesystems
# %common key holds the 'a' name and
# %common value holds the 'b' name
    $bName  = $$common{$aName};
    $amtime = $refa->{$aName} - $tz_bias_a;
    $bmtime = $refb->{$bName} - $tz_bias_b;
    $atype  = $refatype->{$aName};
    $btype  = $refbtype->{$bName};
    $afile  = $r_con->{dira} . $aName;
    $bfile  = $r_con->{dirb} . $bName;

# if btype is a file, and atype a directory, and we write a>b then ignore time rules
# - we will remove the directory
  if (($btype & 0x01) & !($atype & 0x01)&( $mode =~ /^(a>b)|(a<>b)|(A>B)|(A>B!)$/ )) {
#        printf "AFILE %s %s [%s]\n", $afile,$atype,($atype & 0x01);
#        printf "BFILE %s %s [%s]\n", $bfile,$btype,($btype & 0x01);
        $refb->{$bName} = $amtime if (&$fc($afile,$bfile,$amtime,0,"-->",$atype));
        # also need logic here to remove entries for any files in $bfile directory structure
        # from $refb, $btype etc
      }

# if atype is a file, and btype a directory, and we write a
# - we will remove the directory
  if (($atype & 0x01) & !($btype & 0x01)&( $mode =~ /^(ab)|(A
#        printf "AFILE %s %s [%s]\n", $afile,$atype,($atype & 0x01);
#        printf "BFILE %s %s [%s]\n", $bfile,$btype,($btype & 0x01);
        $refa->{$aName} = $bmtime if (&$fc($afile,$bfile,$amtime,$bmtime,"<--",$btype));
        # also need logic here to remove entries for any files in $afile directory structure
        # from $refa, $atype etc
      }

if ((($atype & 0x01) != ($btype & 0x01))&( $mode =~ /^(A<>B)$/ )) {
#        printf "AFILE %s %s [%s]\n", $afile,$atype,($atype & 0x01);
#        printf "BFILE %s %s [%s]\n", $bfile,$btype,($btype & 0x01);
         printf "objects %s and %s are different types, mode does not allow an action to be taken\n",$afile, $bfile;
}



# Skip directories as their time can't be set (NH251100)
    next if -d $afile;

    if ( $amtime > ($bmtime + $fudge) ) {
      $amtime += $tz_bias_b;
      if ( $mode =~ /^(a>b)|(a<>b)|(A>B)|(A>B!)|(A<>B)$/ ) {
        #if ( -f $afile ) {
        #  print " $afile --> $bfile\n" if ($verbose >= 1);
        #  print "  ($amtime) --> ($bmtime)\n" if ($verbose >= 2);
        #}
        $refb->{$bName} = $amtime if (&$fc($afile,$bfile,$amtime,$bmtime,"-->",$atype));
      }
      }elsif ( ($amtime + $fudge) < $bmtime ) {
      $bmtime += $tz_bias_a;
      if ( $mode =~ /^(ab)|(AB)$/ ) {
        #if ( -f $afile ) {
        #  print " $afile <-- $bfile\n" if ($verbose >= 1);
        #  print "  ($amtime) <-- ($bmtime)\n" if ($verbose >= 2);
        #}
        $refa->{$aName} = $bmtime if (&$fc($afile,$bfile,$amtime,$bmtime,"<--",$btype));
      }
    }
  }
  }elsif( $caller eq "Delete" ) {
  foreach my $f (@$amatch) {
    next unless exists $refa->{$f};
    $afile  = $r_con->{dira} . $f;
    $amtime = $refa->{$f} - $tz_bias_a + $tz_bias_b;
    $atype  = $refatype->{$f};
    if (&$del($afile, $amtime)) {
      if ($commit) {
        delete $refa->{$f};
        delete $refatype->{$f};
# remove reference to this file from the arrays @aonly etc.
      }
    }
  }

  }elsif( $caller eq "Rename" ) {
    $nsub =~ m/^(.)/;
    my($sep) = ($1);
    if ( $nsub =~ m/^$sep(.*)$sep(.*)$sep(.*)?$/ ) {
      my($match,$replace,$arg) = ($1,$2,$3);
#      print "nsub $nsub\n";
#      print "sep: $sep\nmatch : $match\n replace: $replace\narg: $arg\n";
      foreach my $f (@$amatch) {
        next unless exists $refa->{$f};
        my($newname) = $f;
        $newname =~ s/$match/$replace/;
        next if ($newname eq $f); # next file if no change...
        $afile  = $r_con->{dira} . $f;
        my ($Afile) = $r_con->{dira} . $newname;
        if (&$mv($afile,$Afile)){
          $refa->{$Afile}     = $refa->{$f};
          $refatype->{$Afile} = $refatype->{$f};
          delete $refa->{$f};
          delete $refatype->{$f};
        }
      }
    }else{
      carp "unable to understand substition  argument $nsub\n";
    }
  }

#  add references to allow @aonly, @bonly etc to be recalled from the reference
my($retval);
$retval->{amatch} = $amatch;
$retval->{bmatch} = $bmatch;
$retval->{aonly}  = $aonly;
$retval->{bonly}  = $bonly;
$retval->{common} = $common;
benchmark("synch files") if $r_con->{bmark};
return $retval;
}

#=====================================================================
# Support old method call
sub SetDefaults {
return New @_;
}
#=====================================================================
sub _arraysort {
  my($r_con, $regex, $negregex, $nocase) = @_;
  my(@amatch,@bmatch,@tfiles,%common,@aonly,@bonly,@temp,$name,$mtime,$type);
  my(@sorted_amatch,@sorted_bmatch,$aName,$bName,$aIndex,$bIndex);
  my %dup      = ();
  my $refa     = $r_con->{alist};
  my $refatype = $r_con->{atype};
  my $refb     = $r_con->{blist};
  my $refbtype = $r_con->{btype};
  my $regexextn = $nocase ? '(?i)' : '';  # use regex extention (?i) if working with case insensitive file systems

# Find files matching the regex in dira
  print "Files Matching regex in $r_con->{dira}:\n" if ($r_con->{verbose} >= 4);
  foreach $name (keys %$refa) {
    if ( $name && ($name =~ /$regexextn$regex/) && ($name !~ /$regexextn$negregex/) ) {
      push (@amatch,$name);
      #printf"  %s  %s  %s\n",%$refa->{$name},%$refatype->{$name},$name if ($r_con->{verbose} >= 4);
    }
  }
# Find files matching the regex in dirb
  print "Files Matching regex in $r_con->{dirb}:\n" if ($r_con->{verbose} >= 4);
  foreach $name (keys %$refb) {
    if ( $name && $name =~ /$regexextn$regex/ && $name !~ /$regexextn$negregex/ ) {
      push (@bmatch,$name);
      #printf"  %s  %s  %s\n",%$refb->{$name},%$refbtype->{$name},$name if ($r_con->{verbose} >= 4);
    }
  }
# Build a list of files that have an added extension ".remove" - to be deleted by tombstone routines later
  @tfiles =     grep { /.+\.remove$/i } @amatch;  # get alist files/dirs with .remove extension
  push @tfiles, grep { /.+\.remove$/i } @bmatch;  # get blist files/dirs with .remove extension
  @tfiles =     grep { ! $dup{$_} ++  } @tfiles;  # remove duplicates

# Find elements that are common/unique to @amatch and @bmatch
# -put in sorted order so that we can create directories/files
#  in one sweep (ie we don't try to create a file before its
#  parent directory exists)
#
# On non-case sensitive filesystems (e.g Bill's) ignore the case
# when testing for matching files.  This will still allow repl to
# create / update files maintaining their original case. (NH311000)
  $aIndex = 0;
  $bIndex = 0;
  @sorted_amatch = $nocase ? sort {lc($a) cmp lc($b) } @amatch : sort @amatch;
  @sorted_bmatch = $nocase ? sort {lc($a) cmp lc($b) } @bmatch : sort @bmatch;

  while ( $aIndex < @sorted_amatch ) {
    last unless defined $sorted_bmatch[$bIndex];  # End of b list
    $aName = $sorted_amatch[$aIndex];
    $bName = $sorted_bmatch[$bIndex];
    if ($aName eq $bName || ($nocase && lc($aName) eq lc($bName))) {
      $common{$aName} = $bName;  # Store $aName as key and $bName as value
      $aIndex++;
      $bIndex++;
    }elsif (($nocase && lc($aName) lt lc($bName)) || (!$nocase && $aName lt $bName)) {
      push(@aonly,$aName);
      $aIndex++;
    }else{
      push(@bonly,$bName);
      $bIndex++;
    }
  }
# Get any remainder of 'a' list
  while ( $aIndex < @sorted_amatch ) {
    push(@aonly,$sorted_amatch[$aIndex++]);
  }
# Get any remainder of 'b' list
  while ($bIndex < @sorted_bmatch) {
    push(@bonly,$sorted_bmatch[$bIndex++]);
  }

  @aonly = reverse sort @aonly; # Sort so that file preceed directories - allows deltree to delete
  @bonly = reverse sort @bonly; # files before directories

  if ( $r_con->{verbose} >= 3 ) {
    print "Common Files :\n";
    foreach (keys %common) {
      print "  $_\n  $common{$_}\n";
    }
    print "A dir only Files :\n";
    foreach (@aonly) {
      print "  $_\n";
    }
    print "B dir only Files :\n";
    foreach (@bonly) {
      print "  $_\n";
    }
    print "\n\nEnd of File Lists ...\n\n";
  }
  return (\@tfiles, \%common, \@aonly, \@bonly, \@amatch, \@bmatch);
}
#=====================================================================
#  If this is called with with "init" argument this initialises global variable @times
#  - a record of user and system times;
#  Otherwise difference since last init (user and system times) is printed to STDOUT
my @times; # global var
sub benchmark ($@) {
my($str,$r1,$u1,$s1) = @_;
@times = $r1 ? ($r1,$u1,$s1) : ( $runtime, times), return if $str eq "init";
($r1,$u1,$s1)   = @times unless $r1;
my($r2,$u2,$s2) = ( $runtime, times);
printf "  %-13s: %2d secs  ( %.2f usr + %.2f sys = %.2f CPU )\n",
$str, $r2-$r1, $u2-$u1, $s2-$s1, $u2-$u1 + $s2-$s1;
}
#=====================================================================
sub elapsed{
  my($start_time)=@_;
  my($elapsed) = $start_time - time;
  return $elapsed;
}
#=====================================================================
sub deltree2{
  my($root)=@_;
  my(@dirlist);
  sub finddir {
    if ( -d ) {
		push (@dirlist,$File::Find::name);
    }
  }
  sub findfile {
  if ( -f ) {
     print " -   unable to delete $File::Find::name \n" if (! unlink $File::Find::name );
  }
}
  find(\&findfile,$root);
  find(\&finddir,$root);
    while ( @dirlist ) {
    my $dir = pop(@dirlist);
    print "   -   unable to remove $dir\n" if (! rmdir($dir) );
  }
    print "   -   unable to remove $root\n" if (! rmdir($root) );

}
#========================================================================
1;
__END__