# @(#) File::Repl - Perl module that provides file replication utilities
#
# Author:
#      Dave Roberts
#
# Synopsis:
#
#     use File::Repl;
#
#     %con = (
#        'dira',      'D:/perl',
#        'dirb',      'M:/perl',
#        'verbose',   '1',
#        'age',       '10',
#        );
#
#     $ref=File::Repl->New(%con);
#     $ref->Update('\.p(l|m)','a<>b',1);
#     $ref->Update('\.t.*','a<>b',1,'\.tmp$');
#
# Version
#      $Source: D:/src/perl/File-Repl/RCS/repl.pm $
#      $Revision: 1.3.5.0 $
#      $State: Exp $
#
# Start comments/code here - will not be processed into manual pages
#
#    Copyright © Dave Roberts  2000
#
# Revision history:
#      $Log: repl.pm $
#      Revision 1.3.5.0  2001/06/19 10:34:11  jj768
#      Revised calling of the New method to use a hash reference, rather
#      than a hash directly
#
#      Revision 1.3.4.0  2001/06/19 09:48:38  jj768
#      intermediate development revision.  Introduced Delete method and the _generic
#      subroutine (used for all methods except New)
#      this is preparatory to the hash being passed as a reference
#
#      Revision 1.3.3.0  2001/06/14 15:42:48  jj768
#      minor code changes in constructing hash and improvement in documentation
#      -still need more docs on Timezones.
#
#      Revision 1.3.2.0  2001/06/14 13:13:57  jj768
#      incorporated tombstoning updates, recursion changes and file timestamp
#      changes - esp. to incorporate DOS file system timestamping.  All thanks
#      to Nigel Hodgson
#
#      Revision 1.2.0.1  2000/10/27 08:38:43  jj768
#      Simple RCS version update to give 4 digit revision
#
#      Revision 1.2  2000/10/27 08:35:01  jj768
#      New branch created to allow perl checking of revision number (perl can only check
#      A.B in RCS revision A.B.C.D).  This required because of renaming SetDefaults with New
#
#      Revision 1.1.0.2  2000/10/27 07:53:44  jj768
#      set $VERSION correctly from RCS variable
#
#      Revision 1.1.0.1  2000/10/20 09:51:09  jj768
#      Synchronised RCS and module version numbers, and fixed miscellaneous minor errors
#
#      Revision 1.1  2000/10/20 08:35:20  Dave.Roberts
#      Initial revision
#
#******************************************************************************
package File::Repl;

use strict;
use Carp;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD);
use File::Find;
use File::Copy;
use File::Basename;
use constant FALSE                => 0;
use constant TRUE                 => 1;
use constant TIME_ZONE_ID_INVALID => 0xFFFFFFFF;

#**************************************************************
# 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 ?
  eval "use Win32::API";
  eval "use Win32::AdminMisc";
  
  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;
require DynaLoader;
require AutoLoader;

@ISA = qw(Exporter DynaLoader);
# 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.
@EXPORT = qw();
@EXPORT_OK = qw();
$VERSION = sprintf("%d.%d.%d.%d", q$Revision: 1.3.5.0 $ =~ /(\d+)\.(\d+)\.(\d+)\.(\d+)/);

sub AUTOLOAD {
# This AUTOLOAD is used to 'autoload' constants from the constant()
# XS function.  If a constant is not found then control is passed
# to the AUTOLOAD in AutoLoader.
  
# Never propagate DESTROY methods
  return if $AUTOLOAD =~ /::DESTROY$/;
  
  my $constname;
  ($constname = $AUTOLOAD) =~ s/.*:://;
  croak "& not defined" if $constname eq 'constant';
  my $val = constant($constname, @_ ? $_[0] : 0);
  if ($! != 0) {
    if ($! =~ /Invalid/) {
      $AutoLoader::AUTOLOAD = $AUTOLOAD;
      goto &AutoLoader::AUTOLOAD;
    }
    else {
      croak "Your vendor has not defined Repl macro $constname";
    }
  }
  *$AUTOLOAD = sub () { $val };
  goto &$AUTOLOAD;
}

#---------------------------------------------------------------------
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  => $conf->{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
  };
  
# Added boolean 'recurse' key to hash and default to true if
# not defined. This allows faster build of file lists when
# only interested in top level directory.  (NH311000)
  my $recurse = $r_con->{recurse};
  
# Should we continue if dira / dirb dosn't exist ?  (NH301200)
  my $mkdirs = $r_con->{mkdirs};
  
  my $benchmark = $r_con->{bmark};
  
  if ( $conf->{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 $benchmark;
  if ( -d $r_con->{dira} ) {
    if ($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;
    }
    }elsif (!$mkdirs) {
    croak "Invalid directory name for dira ($r_con->{dira})\n";
  }
  benchmark("build A list") if $benchmark;
  
# Build the B list
  benchmark("init") if $benchmark;
  if ( $r_con->{dira} eq $r_con->{dirb} ) {
    $blist = $alist;
    $btype = $atype;
    }elsif ( -d $r_con->{dirb} ) {
    if ($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;
    }
    }elsif (!$mkdirs) {
    croak "Invalid directory name for dirb ($r_con->{dirb})\n";
  }
  benchmark("build B list") if $benchmark;
  
  $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 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,@temp,%vol);
my($tName,$aName,$bName,$deltree,$truncate,$touch,$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;

# On FAT filesystems, mtime resolution is 1/30th of a second.
# Increase fudge to 2 to allow for A <> DOS <> B e.g. syncing
# two machines via a zip disk  (NH311000)
my $fudge = 2;

if ($caller eq "Update") {
if ( scalar(@_) == 4 ) {
  ($r_con,$regex,$mode,$commit) = @_;
  }elsif ( scalar(@_) == 5 ) {
  ($r_con,$regex,$negregex,$mode,$commit) = @_;
  }else{
  carp ("Try calling the File::Repl->Update method with the right arguments !\n");
  print scalar(@_), " Args called ( @_ )\n";
  return;
}
}elsif($caller eq "Delete"){
  if ( scalar(@_) eq 3 ) {
  ($r_con,$regex,$commit) =@_;
# can be of zero length name.
  }elsif ( scalar(@_) eq 4 ) {
  $r_con,$regex,$negregex,$commit =@_;
  }else{
  carp ("Try calling the File::Repl->Delete method with the right arguments !\n");
}elsif($caller eq "Rename"){
  if ( scalar(@_) eq 4 ) {
    ($r_con,$regex,$nsub,$commit) =@_;
# can be of zero length name.
  }elsif ( scalar(@_) eq 5 ) {
    ($r_con,$regex,$negregex,$nsub,$commit) =@_;
  }else{
    carp ("Try calling the File::Repl->Rename method with the right arguments !\n");
  }
}

my $nocase = $r_con->{nocase};

# Expiry time for tombstone indicator files in seconds
my $ttl = $r_con->{ttl} * 60 * 60 * 24;

$mode      = 'a>b' if ( $mode eq "" );      # Set the default operating mode
$commit    = TRUE unless defined $commit;   # Set default commit value
$verbose   = $r_con->{verbose};
$agelimit  = $r_con->{agelimit} ? $r_con->{agelimit} * 86400 : 0;
$benchmark = $r_con->{bmark};

# Fix for stat/utime on FAT filesystems (NH270301)
if ($TZ_BIAS) {
  %vol = Win32::AdminMisc::GetVolumeInfo( $r_con->{dira} );
  $tz_bias_a = $TZ_BIAS if ($vol{FileSystemName} =~ /FAT/);
  %vol = Win32::AdminMisc::GetVolumeInfo( $r_con->{dirb} );
  $tz_bias_b = $TZ_BIAS if ($vol{FileSystemName} =~ /FAT/);
  $tz_bias_a = $tz_bias_b = 0 if ($tz_bias_a && $tz_bias_b);
}

if ($verbose >= 3) {
  print "Update\n  Regex    : $regex\n  NegRegex : $negregex\n";
  print "  Mode     : $mode\n  Commit   : $commit\n";
  print "  AgeLimit : $r_con->{agelimit}  ($agelimit)\n";
  print "  Tombstone File TTL : $ttl\n";
  print "  DirA DOS time adj : $tz_bias_a\n";
  print "  DirB DOS time adj : $tz_bias_b\n\n";
}
# Ensure no matches if $negregex = ''
$negregex = '^$' unless $negregex;

# Sort files using regex and negregex
benchmark("init") if $benchmark;
($tfiles,$common,$aonly,$bonly,$amatch,$refa,$refb,$refatype,$refbtype) =
_arraysort($r_con, $regex, $negregex, $nocase) ;
benchmark("match files") if $benchmark;
#****************************************************************
# sub to copy files and build directory structure
#****************************************************************
$fc = sub {
  my($a,$b,$amtime,$bmtime,$mode) = @_;
  my($btmp);
  
# Ignore the file if agelimit is switched on and file exceeds
# this
  if ( $agelimit && (( time - $amtime ) > $agelimit )) {
    print " $a ignored - exceeds age limit \n" if $verbose > 1;
    return FALSE;
  }
  return TRUE unless $commit;
  
# Make sure the parent of the target file exists
  return FALSE unless &$md(dirname($b));
  
  if ( -f $a ) {
    if ( -f $b ) {
# If we have a file to copy, and we are replacing a previous version create a filename
# that we can rename the previous version to.
      $btmp = $b . '.X';
      while ( -f $btmp ) {
        $btmp .= 'X';
        print " *************** $btmp\n";
      }
# rename old copy of $b - to restore if the copy fails
      unless ( rename ($b, $btmp) ) {
        carp "Unable to create temp copy of $b ($btmp) \n";
        undef $btmp;
      }
    }
    
    if ( copy ($a,$b) ) {
# ******
# 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 ) {
# If we had renamed a previous version of file (for potential recovery) we
# delete it now.
        unlink $btmp || carp "Failed to delete temporary file $btmp\n";
      }
      return TRUE;
      }else{
      carp "unable to copy $a\n";
      if ( $btmp ) {
# If we had renamed a previous version of file (for potential recovery) we
# restore it now
        unless ( rename ($btmp, $b) ) {
          carp "Unable to restore $b from temp copy of $btmp following failed file copy\n";
          undef $btmp;
        }
      }
    }
    }else{
    if ( ! -d $b ) {
      mkdir($b,0777) && return TRUE || carp "Unable to create directory $b\n";
    }
#  setting utime doe'nt work on a dir.  Maybe FS rules ??
#utime($amtime,$amtime,$b) || carp "Failed to set modification time on $b\n";
#my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = stat($b);
#print " A mtime $amtime\n B mtime $mtime\n";
  }
  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) = @_;
  if ($verbose >= 1) {
    (-d $targ) ? print "  rmdir  $targ\n" : print "  remove $targ\n";
  }
  if ( $mtime && $agelimit && (( time - $mtime ) > $agelimit )) {
    if ( $verbose >= 1 ) {
      print "$a ignored - exceeds age limit -";
    printf "   (%3.1d days old - limit set is %3d days))\n", (time - $mtime)/(86400), $agelimit/(86400);
  }
  return FALSE;
}
return TRUE unless $commit;
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";
# should do something here ???
# UNIX links ???
}
return FALSE;
};

#****************************************************************
# sub to delete directory trees
#****************************************************************
$deltree = sub {
my($targ,$dir,$reftime,$reftype,$top) = @_;
my $xxx = sub {
  ($tmp = $File::Find::name) =~ s/^\Q$dir//;      # Remove the start directory portion
  return if (!$top && !rindex($tmp, '/'));        # Don't remove top level directory unless $top == TRUE
  chdir $dir if !rindex($tmp, '/');               # Move up to parent if removing top level dir
  delete $$reftime->{$tmp}, delete $$reftype->{$tmp} if &$del($File::Find::name);
};
finddepth(\&$xxx, $dir . $targ);
return if $top;
$commit ? $$reftime->{$targ} = (stat($dir . $targ))[9] : $$reftime->{$targ} = time;
};

#****************************************************************
# 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] : time;
$$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);
}
($$type_ref, $$mtime_ref) = $commit ? (stat($file))[2,9] : time;
};

benchmark("init") if $benchmark;
if ( $caller eq "Update" ) {
#****************************************************************
# Delete tombstoned files (NH261100)
#****************************************************************
foreach $tName (@$tfiles) {
  ($name = $tName) =~ s/.remove$//i;
  
# Delete <dir.remove> 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 <dir> trees and files
  if ($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) < time) && &$del($afile));
  delete $$refb->{$_}, delete $$refbtype->{$_} if ($bfile && (($$refb->{$_} + $ttl) < time) && &$del($bfile));
}

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,"",$atype);
  }
}
if ( $mode =~ /^(A<B)|(A<>B)$/ ) {
  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($bfile,$afile,$bmtime,"",$btype);
  }
}
if ( $mode =~ /^A<B!$/ ) {
  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) {
  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;
  
# 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 =~ /^(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);
      }
      $$refa->{$aName} = $bmtime if (&$fc($bfile,$afile,$bmtime,$amtime,$btype));
    }
  }
}
}elsif( $caller eq "Delete" ) {
foreach (@$amatch) {
  next unless exists $$refa->{$_};
  $afile  = $r_con->{dira} . $_;
  $amtime = $$refa->{$_} - $tz_bias_a + $tz_bias_b;
  $atype  = $$refatype->{$_};
  print " rm $afile\n" if ($verbose >= 1);
  delete $$refa->{$_}, delete $$refatype->{$_} if &$del($afile, $amtime);
}


}

benchmark("synch files") if $benchmark;
}

#=====================================================================
# 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 $verbose  = $r_con->{verbose};
my $refa     = $r_con->{alist};
my $refatype = $r_con->{atype};
my $refb     = $r_con->{blist};
my $refbtype = $r_con->{btype};

# If dealing with case insensitive filesystems, use regex
# extention (?i) on pattern matching    (NH181200)
my $regexextn = $nocase ? '(?i)' : '';

# Find files matching the regex in dira
print "Files Matching regex in $r_con->{dira}:\n" if ($verbose >= 4);
foreach $name (keys %$$refa) {
if ( $name && ($name =~ /$regexextn$regex/) && ($name !~ /$regexextn$negregex/) ) {
  push (@amatch,$name);
  if ($verbose >= 4) {
    $mtime = %$$refa->{$name};
    $type  = %$$refatype->{$name};
    print "  $mtime  $type  $name\n";
  }
}
}
# Find files matching the regex in dirb
print "Files Matching regex in $r_con->{dirb}:\n" if ($verbose >= 4);
foreach $name (keys %$$refb) {
if ( $name && $name =~ /$regexextn$regex/ && $name !~ /$regexextn$negregex/ ) {
  push (@bmatch,$name);
  if ($verbose >= 4) {
    $mtime = %$$refb->{$name};
    $type  = %$$refbtype->{$name};
    print "  $mtime  $type  $name\n";
  }
}
}

# Build a list of files that have an added extension ".remove"
# These indicate tombstoned files that will be deleted from
# all replications.     (NH261100)
@tfiles =     grep { /.+\.remove$/i } @amatch;  # get alist files
push @tfiles, grep { /.+\.remove$/i } @bmatch;  # get blist files
@tfiles =     grep { ! $dup{$_} ++  } @tfiles;  # remove dups

# 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++]);
}

# Sort @aonly and @bonly - so that directories are allways processed after files they contain
# This way we delete the directory only after its empty

#  @temp  = sort { %$$refatype->{$b} <=> %$$refatype->{$a} || length($b) <=> length($a) } @aonly;
#  @aonly = @temp;

#  @temp  = sort { %$$refbtype->{$b} <=> %$$refbtype->{$a} || length($b) <=> length($a) } @bonly;
#  @bonly = @temp;

@aonly = reverse sort @aonly;
@bonly = reverse sort @bonly;

if ( $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 "Replicating ...\n";
}
return (\@tfiles, \%common, \@aonly, \@bonly, \@amatch, $refa,$refb,$refatype,$refbtype);
}
#=====================================================================
my @times; # global var
sub benchmark ($@) {
my($str,$r1,$u1,$s1) = @_;
@times = $r1 ? ($r1,$u1,$s1) : (time, times), return if $str eq "init";
($r1,$u1,$s1)   = @times unless $r1;
my($r2,$u2,$s2) = (time, times);
printf "  %-13s: %2d secs  ( %.2f usr + %.2f sys = %.2f CPU )\n",
$str, $r2-$r1, $u2-$u1, $s2-$s1, $u2-$u1 + $s2-$s1;
}
#=====================================================================


1;

__END__

=head1 NAME

File::Repl - Perl module that provides file replication utilities

=head1 SYNOPSIS

  use File::Repl;

  %con = {
    dira     => 'D:/perl',
    dirb     => 'M:/perl',
    verbose  => '1',
    age      => '10',
  };

  $ref=File::Repl->New(\%con);
  $ref->Update('\.p(l|m)','a<>b',1);
  $ref->Update('\.t.*','a<>b',1,'\.tmp$');

=head1 DESCRIPTION

The File:Repl provides simple file replication and management utilities. Its main
functions are

=over 4

=item File Replication

Allowing two directory structures to be maintained, ensuring files that meet
selection logic criteria are mirrored and otherwise synchronized.

=item Bulk Renaming

Allowing files in a directory structure to be renamed according to the selection
logic.

=item Compressing

Allowing files in a directory structure to be compressed according to a given logic.

=item Process

Run a common perl process against files in a directory structure according to selection
logic.

=item Deletion

Allowing files in a directory structure to be deleted according to the selection
logic.

=back

=head1 METHODS

=over 2

=item B<New(%con)>

The B<New> method constructs a new File-Repl object.  Options are passed in the form of a hash
reference I<\%con> which define the file directories to be operated on and other parameters.
The directories are scanned and each file is stat'ed.   The hash keys have the following definitions-

=over 4

=item dira

This identifies the first directory to be scanned (required).

=item dirb

This identifies the second directory to be scanned (required).  If the object is only to
have methods operate on it that operate on a single directory then dirb can be set to the
same value as dira.  This minimizes the directory structure to be sesarched.

=item verbose

The verbose flag has several valid values:

=over 8

=item 0

No verbosity (default mode).

=item 1

All file copies and deletes are printed.

=item 2

Tombstone file trunkations are printed, and any timestamp changes made,

=item 3

Configuration settings (from I<%con>) and Files meeting the match criteria are printed.

=item 4

Files identified in each directory that match the regex requirements (from the B<Update>
method) are printed.

=back

=item age

This specifies the  maximum age of a file in days.  Files older than this will
be ignored by Update, Rename, Compress and Delete methods.

=item recurse

When set to FALSE only files at the top level of the B<dira> and B<dirb> are scanned. Default
value is

=item ttl

This is the time to live (B<ttl> for any tombstoned file, in days.  Default value is 31.

=item nocase

Switches for case sensitivity - default is TRUE (case insensitive).

=item mkdirs

If either directory B<dira> or B<dirb> do not exist will attempt to create the directory
if set TRUE.  Default value is FALSE.


=back

=item B<Update(regex, [noregex,] action, commit)>

The B<Update> method makes the file updates requested - determined by the I<%con>
hash (from the B<New> method) and four associated arguments.

This method also allows
files to be tombstoned (ie removed from the replicated file sets).  A file is tombstoned
by appending I<.remove> to the file name.  The first B<Update> will cause the file to be
set to zero size, and any replica files to be renamed (so the original file does not
return).  The next update after the B<ttl> has expired will cause deletion of all file
replicas.

If a directory is tombstoned (by adding I<.remove> to its name) the directory and contents
are removed and a file with the directory name and the I<.remove> suffix replaces it.  The
file is removed as a normally tombstoned file.

=over 0

=item B<regex>

A regular expression, used to match all file names that are to be maintained.

=item B<noregex>

An optional regular expression used to match all files not to be maintained
(ie excluded from the operation).

=item B<action>

defines the action to be performed.

=over 4

=item a>b

Files in the 'a' directory are to be replicated to the 'b' directory
if a replica exists in 'b' directory and the timestamp is older than that
of the file in the 'a' directory.

=item a<b

Files in the 'b' directory are to be replicated to the 'a' directory
if a replica exists in 'a' directory and the timestamp is older than that
of the file in the 'b' directory.

=item a<>b

Files in the 'a' directory are to be replicated to the 'b' directory
if a replica exists in 'b' directory and the timestamp is older than that
of the file in the 'a' directory.  Files in the 'b' directory are to be
replicated to the 'a' directory if a replica exists in 'a' directory and
the timestamp is older than that of the file in the 'b' directory.

=item A>B

Files in the 'a' directory are to be replicated to the 'b' directory
- even if no replica exists in 'b' directory.  If a replica already exists
in the 'b' directory with a timestamp that is newer than that of the file
in the 'a' directory it is not modified.

=item A>B!

Files in the 'a' directory are to be replicated to the 'b' directory
- even if no replica exists in 'b' directory.  If a replica already exists
in the 'b' directory with a timestamp that is newer than that of the file
in the 'a' directory it is not modified.  Orphan files in the 'b'
directory are deleted.

=item A<B

Files in the 'b' directory are to be replicated to the 'a' directory
- even if no replica exists in 'a' directory.  If a replica already exists
in the 'a' directory with a timestamp that is newer than that of the file
in the 'b' directory it is not modified.

=item A<B!

Files in the 'b' directory are to be replicated to the 'a' directory
- even if no replica exists in 'a' directory.  If a replica already exists
in the 'a' directory with a timestamp that is newer than that of the file
in the 'b' directory it is not modified. Orphan files in the 'a'
directory are deleted.

=item A <>B

Files in the 'a' directory are to be replicated to the 'b' directory
- even if no replica exists in 'b' directory.  If a replica already exists
in the 'b' directory with a timestamp that is newer than that of the file
in the 'a' directory it is not modified. Files in the 'b' directory are to
be replicated to the 'a' directory - even if no replica exists in 'a'
directory.  If a replica already exists in the 'a' directory with a
timestamp that is newer than that of the file
in the 'b' directory it is not modified.

=back

=item commit

When set TRUE makes changes required - set FALSE to show potential changes
(which are printed to STDOUT)

=back

=item B<Rename(regex, [noregex], namesub, commit)>

The B<Rename> method is used to rename files in the I<dira> directory structure
in the object specified in the B<New> method.

=over 0

=item regex

A regular expression, used to match all file names that are to be deleted.

=item noregex

An optional regular expression used to match all files not to be deleted
(ie excluded from the operation).

=item namesub

The argument used for a perl substitution command

  e.g. /\.pl$/\.perl\$/

will rename all files (that meet I<regex> and I<noregex> criteria from .pl to .perl

=item commit

When set TRUE makes deletions required - set FALSE to show potential changes
(which are printed to STDOUT)

=back

=item B<Process>

Not yet implemeneted

=item B<Compress>

Not yet implemented

=item B<Delete(regex, [noregex], commit)>

The B<Delete> method removes files from the I<dira> directory structure in the object
specified in the B<New> method.

=over 0

=item B<regex>

A regular expression, used to match all file names that are to be deleted.

=item B<noregex>

An optional regular expression used to match all files not to be deleted
(ie excluded from the operation).

=item commit

When set TRUE makes deletions required - set FALSE to show potential changes
(which are printed to STDOUT)

=back

=head1 TIMEZONE AND FILESYSTEMS

On FAT filesystems, mtime resolution is 1/30th of a second.  A fudge of 2 seconds
is used for synching FAT with other filesystems.  Note that FAT filesystems
save the local time in UTC (GMT).

On FAT filesystems, "stat" adds TZ_BIAS to the actual file times (atime, ctime and
mtime) and conversley "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.


=head1 AUTHOR

Dave Roberts



=head1 SUPPORT

You can send bug reports and suggestions for improvements on this module
to me at DaveRoberts@iname.com. However, I can't promise to offer
any other support for this script.

=head1 COPYRIGHT

This module is Copyright © 2000, 2001 Dave Roberts. All rights reserved.

This script is free software; you can redistribute it and/or modify it
under the same terms as Perl itself. This script is distributed in the
hope that it will be useful, but WITHOUT ANY WARRANTY; without even
the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
PURPOSE. The copyright holder of this script can not be held liable
for any general, special, incidental or consequential damages arising
out of the use of the script.

=head1 CHANGE HISTORY

$Log: repl.pm $
Revision 1.3.5.0  2001/06/19 10:34:11  jj768
Revised calling of the New method to use a hash reference, rather
than a hash directly

Revision 1.3.4.0  2001/06/19 09:48:38  jj768
intermediate development revision.  Introduced Delete method and the _generic
subroutine (used for all methods except New)
this is preparatory to the hash being passed as a reference

Revision 1.3.3.0  2001/06/14 15:42:48  jj768
minor code changes in constructing hash and improvement in documentation
-still need more docs on Timezones.


=cut
