File Coverage

blib/lib/File/DirSync.pm

Criterion	Covered	Total	%
statement	83	418	19.8
branch	9	340	2.6
condition	5	99	5.0
subroutine	21	43	48.8
pod	19	21	90.4
total	137	921	14.8

package File::DirSync;

use strict;
use Exporter;
use Fcntl qw(O_CREAT O_RDONLY O_WRONLY O_EXCL);
use Carp qw(croak);

use vars qw( $VERSION @ISA $PROC );
$VERSION = '1.22';
@ISA = qw(Exporter);
$PROC = join " ", $0, @ARGV;

# Whether or not symlinks are supported
use constant HAS_SYMLINKS => ($^O !~ /Win32/i) || 0;

# Wallclock percent spent sleeping
use constant GENTLE_PERCENT_DEFAULT => 50;
use constant GENTLE_PERCENT_MIN     =>  0;
use constant GENTLE_PERCENT_MAX     => 99;

# Disk Operations to run without sleeping
use constant GENTLE_OPS_DEFAULT     => 1_000;
use constant GENTLE_OPS_MIN         => 10;
use constant GENTLE_OPS_MAX         => 20_000_000;

# Automatically increase maxops by GENTLE_CHEWINCFACTOR
# whenever realtime spent syncing is under GENTLE_CHEWMINTIME
# or sleeptime is under GENTLE_SLEEPMINTIME.
use constant GENTLE_CHEWINCFACTOR   => 0.25;
use constant GENTLE_CHEWMINTIME     => 2;
use constant GENTLE_SLEEPMINTIME    => 2;
use constant GENTLE_SLEEPMAXTIME    => 600;

# Number of bytes that can read and write to and from a local file in one syscall
use constant BUFSIZE => 8192;

# Number of bytes written to consider as one "disk op"
use constant BLKSIZE => 1024;

# Number of ops to be considered for each iteration during a file copy.
# (This counts both the read and write ops for the buffer.)
use constant BUFFER_OPS => BUFSIZE / BLKSIZE * 2;

sub new {
  my $class = shift;
  my $self = shift || {};
  $self->{only} ||= [];
  $| = 1 if $self->{verbose};
  bless $self, $class;
  return $self;
}

sub proctitle {
  my $self = shift;
  $self->{proctitle} ||= shift || $0;
  return $self->{proctitle};
}

sub gentle {
  my $self = shift;

  $self->{_gentle_percent} = shift || GENTLE_PERCENT_DEFAULT;
  $self->{_gentle_percent} = GENTLE_PERCENT_MIN if $self->{_gentle_percent} < GENTLE_PERCENT_MIN;
  $self->{_gentle_percent} = GENTLE_PERCENT_MAX if $self->{_gentle_percent} > GENTLE_PERCENT_MAX;

  $self->{_gentle_maxops} = shift || GENTLE_OPS_DEFAULT;
  $self->{_gentle_maxops} = GENTLE_OPS_MIN if $self->{_gentle_maxops} < GENTLE_OPS_MIN;
  $self->{_gentle_maxops} = GENTLE_OPS_MAX if $self->{_gentle_maxops} > GENTLE_OPS_MAX;

  $self->{_gentle_started} = time;
  $self->{_gentle_ops} = 0;

  return $self->{_gentle_percent};
}

sub _op {
  my $self = shift;
  if (($self->{_gentle_ops} += (shift || 1) ) >= $self->{_gentle_maxops}) {
    # Reached maximum operations
    my $elapsed = time - $self->{_gentle_started};
    my $delay = int ($elapsed / (100/$self->{_gentle_percent} - 1)) || 1;
    if ($self->{_gentle_maxops} < GENTLE_OPS_MAX and
        $elapsed < GENTLE_CHEWMINTIME ||
        $delay < GENTLE_SLEEPMINTIME) {
      $self->{_gentle_maxops} += int ($self->{_gentle_maxops} * GENTLE_CHEWINCFACTOR);
      $self->{_gentle_maxops} = GENTLE_OPS_MAX if $self->{_gentle_maxops} > GENTLE_OPS_MAX;
    } elsif ($delay > GENTLE_SLEEPMAXTIME) {
      $self->{_gentle_maxops} -= int ($self->{_gentle_maxops} * GENTLE_CHEWINCFACTOR);
      $delay = GENTLE_SLEEPMAXTIME;
    }
    my $prevproc = $0;
    $0 = "$self->{proctitle} - [$self->{_gentle_percent}% gentle on $self->{_gentle_maxops} ops]: SLEEPING $delay UNTIL: ".scalar(localtime (time() + $delay)) if $self->{proctitle};
    sleep $delay;
    $0 = $prevproc;
    $self->{_gentle_started} = time;
    $self->{_gentle_ops} = 0;
  }
  return 1;
}

sub rebuild {
  my $self = shift;
  my $dir = shift || $self->{src};

  croak 'Source directory must be specified: $obj->rebuild($directory) or define $obj->src($directory)'
    unless defined $dir;

  # Remove trailing / if accidently supplied
  $dir =~ s%/$%%;
  -d $dir or
    croak 'Source must be a directory';

  if (@{ $self->{only} }) {
    foreach my $only (@{ $self->{only} }) {
      if ($only =~ /^$dir/) {
        $self->_rebuild( $only );
      } else {
        croak "$only is not a subdirectory of $dir";
      }
      local $self->{localmode} = 1;
      while ($only =~ s%/[^/]*$%% && $only =~ /^$dir/) {
        $self->_rebuild( $only );
      }
    }
  } else {
    $self->_rebuild( $dir );
  }
  $0 = $PROC if $self->{proctitle};
  print "Rebuild cache complete.\n" if $self->{verbose};
}

sub _rebuild {
  my $self = shift;
  my $dir = shift;

  # Hack to snab a scoped file handle.
  my $handle = do { local *FH; };
  $dir = $1 if $dir =~ m%^(.*)$%;
  $self->_op if $self->{_gentle_percent};
  return unless opendir($handle, $dir);
  $0 = "$self->{proctitle} - rebuild: $dir" if $self->{proctitle};
  $self->_op if $self->{_gentle_percent};
  my $current = (lstat $dir)[9];
  my $most_current = $current;
  my $node;
  my $skew = $self->{maxskew};
  if (defined $skew) {
    $skew += time;
    if ($current > $skew) {
      $most_current = $current = $skew;
    }
  }
  $self->_op if $self->{_gentle_percent};
  while (defined ($node = readdir($handle))) {
    next if $node =~ /^\.\.?$/;
    next if $self->{ignore}->{$node};
    my $path = "$dir/$node";
    # Recurse into directories to make sure they
    # are updated before comparing time stamps
    $self->_op if $self->{_gentle_percent};
    !$self->{localmode} && !-l $path && -d _ && $self->_rebuild( $path );
    my $this_stamp = (lstat $path)[9];
    next if -l _;
    if (defined $skew) {
      $self->_op if $self->{_gentle_percent};
      if ($this_stamp > $skew and !-l $path) {
        print "Clock skew detected [$path] ".($this_stamp-$skew)." seconds in the future? Repairing...\n" if $self->{verbose};
        utime($skew, $skew, $path);
        $this_stamp = $skew;
      }
    }
    if ($this_stamp > $most_current) {
      print "Found a newer node [$path]\n" if $self->{verbose};
      $most_current = $this_stamp;
    }
  }
  closedir($handle);
  if ($most_current > $current) {
    print "Adjusting [$dir]...\n" if $self->{verbose};
    $most_current = $1 if $most_current =~ /^(\d+)$/;
    $self->_op if $self->{_gentle_percent};
    utime($most_current, $most_current, $dir);
  }
  return;
}

sub tracking {
  my $self = shift;
  if (@_) {
    if (shift) {
      $self->{_tracking} = {
        removed => [],
        updated => [],
        skipped => [],
        failed  => [],
      };
    } else {
      delete $self->{_tracking};
    }
  }
  return ($self->{_tracking} ? 1 : 0);
}

sub dirsync {
  my $self = shift;
  my $src = shift || $self->{src};
  my $dst = shift || $self->{dst};
  croak 'Source and destination directories must be specified: $obj->dirsync($source_directory, $destination_directory) or specify $obj->to($source_directory) and $obj->src($destination_directory)'
    unless (defined $src) && (defined $dst);

  # Remove trailing / if accidently supplied
  $src =~ s%/$%%;
  -d $src or
    croak 'Source must be a directory';
  # Remove trailing / if accidently supplied
  $dst =~ s%/$%%;
  my $upper_dst = $dst;
  $upper_dst =~ s%/?[^/]+$%%;
  if ($upper_dst && !-d $upper_dst) {
    croak "Destination root [$upper_dst] must exist: Aborting dirsync";
  }
  $self->_dirsync( $src, $dst );
  $0 = $PROC if $self->{proctitle};
  return;
}

sub _dirsync {
  my $self = shift;
  my $src = shift;
  my $dst = shift;

  $self->_op(2) if $self->{_gentle_percent};
  my $when_dst = (lstat $dst)[9];
  my $size_dst = -s _;
  my @stat_src = lstat $src;
  my $when_src = $stat_src[9];
  my $size_src = $stat_src[7];

  if (HAS_SYMLINKS) {
    # Symlink Check must be first because
    # I could not figure out how to preserve
    # timestamps (without root privileges).
    if (-l _) {
      # Source is a symlink
      $self->_op(2) if $self->{_gentle_percent};
      my $point = readlink($src);
      if (-l $dst) {
        # Dest is a symlink, too
        if ($point eq (readlink $dst)) {
          # Symlinks match, nothing to do.
          $self->_op if $self->{_gentle_percent};
          return;
        }
        # Remove incorrect symlink
        print "$dst: Removing symlink\n" if $self->{verbose};
        unlink $dst or warn "$dst: Failed to remove symlink: $!\n";
        $self->_op(2) if $self->{_gentle_percent};
      }
      if (-d $dst) {
        # Wipe directory
        print "$dst: Removing tree\n" if $self->{verbose};
        $self->rmtree($dst) or warn "$dst: Failed to rmtree!\n";
      } elsif (-e $dst) {
        # Regular file (or something else) needs to go
        print "$dst: Removing\n" if $self->{verbose};
        unlink $dst or warn "$dst: Failed to purge: $!\n";
      }
      if (-l $dst || -e $dst) {
        warn "$dst: Still exists after wipe?!!!\n";
      }
      $point = $1 if $point =~ /^(.+)$/; # Taint
      # Point to the same place that $src points to
      print "$dst -> $point\n" if $self->{verbose};
      symlink $point, $dst or warn "$dst: Failed to create symlink: $!\n";
      $self->_op(5) if $self->{_gentle_percent};
      return;
    }
  }

  if ($self->{nocache} && -d _) {
    $size_dst = -1;
  }
  # Short circuit and kick out the common case:
  # Nothing to do if the timestamp and size match
  if ( defined ( $when_src && $when_dst && $size_src && $size_dst) &&
       $when_src == $when_dst && $size_src == $size_dst ) {
    push @{ $self->{_tracking}->{skipped} }, $dst if $self->{_tracking};
    return;
  }

  # Regular File Check
  if (-f _) {
    # Source is a plain file
    if (-l $dst) {
      # Dest is a symlink
      print "$dst: Removing symlink\n" if $self->{verbose};
      unlink $dst or warn "$dst: Failed to remove symlink: $!\n";
      $self->_op if $self->{_gentle_percent};
    } elsif (-d _) {
      # Wipe directory
      print "$dst: Removing tree\n" if $self->{verbose};
      $self->rmtree($dst) or warn "$dst: Failed to rmtree: $!\n";
    }
    $self->_op if $self->{_gentle_percent};
    $0 = "$self->{proctitle} - copying: $src => $dst" if $self->{proctitle};
    if ($self->copy($src, $dst)) {
      print "$dst: Updated\n" if $self->{verbose};
      push @{ $self->{_tracking}->{updated} }, $dst if $self->{_tracking};
    } else {
      warn "$dst: Failed to copy: $!\n";
    }
    if (!-e $dst) {
      warn "$dst: Never created?!!!\n";
      push @{ $self->{_tracking}->{failed} }, $dst if $self->{_tracking};
      $self->_op if $self->{_gentle_percent};
      return;
    }
    # Force permissions to match the source
    chmod( $stat_src[2] & 0777, $dst) or warn "$dst: Failed to chmod: $!\n";
    # Force user and group ownership to match the source
    chown( $stat_src[4], $stat_src[5], $dst) or warn "$dst: Failed to chown: $!\n";
    # Force timestamp to match the source.
    utime $when_src, $when_src, $dst or warn "$dst: Failed to utime: $!\n";
    $self->_op(4) if $self->{_gentle_percent};
    return;
  }

  # Missing Check
  if (!-e _) {
    # The source does not exist
    # The destination must also not exist
    print "$dst: Removing\n" if $self->{verbose};
    $0 = "$self->{proctitle} - removing: $dst" if $self->{proctitle};
    if ( $self->rmtree($dst) ) {
      push @{ $self->{_tracking}->{removed} }, $dst if $self->{_tracking};
    } else {
      push @{ $self->{_tracking}->{failed} }, $dst if $self->{_tracking};
      warn "$dst: Failed to rmtree!\n";
    }
    return;
  }

  # Finally, the recursive Directory Check
  if (-d _) {
    # Source is a directory
    if (-l $dst) {
      # Dest is a symlink
      print "$dst: Removing symlink\n" if $self->{verbose};
      unlink $dst or warn "$dst: Failed to remove symlink: $!\n";
      $self->_op if $self->{_gentle_percent};
    }
    if (-f $dst) {
      # Dest is a plain file
      # It must be wiped
      print "$dst: Removing file\n" if $self->{verbose};
      if ( unlink($dst) ) {
        push @{ $self->{_tracking}->{removed} }, $dst if $self->{_tracking};
      } else {
        push @{ $self->{_tracking}->{failed} }, $dst if $self->{_tracking};
        warn "$dst: Failed to unlink file: $!\n";
      }
      $self->_op if $self->{_gentle_percent};
    }
    if (!-d $dst) {
      if ( mkdir $dst, 0755 ) {
        push @{ $self->{_tracking}->{updated} }, $dst if $self->{_tracking};
      } else {
        push @{ $self->{_tracking}->{failed} }, $dst if $self->{_tracking};
        warn "$dst: Failed to mkdir: $!\n";
      }
      $self->_op if $self->{_gentle_percent};
    }
    -d $dst or warn "$dst: Destination directory cannot exist?\n";
    $self->_op(4) if $self->{_gentle_percent};

    # If nocache() was not specified, then it is okay
    # skip this directory if the timestamps match.
    if (!$self->{nocache}) {
      # (The directory sizes do not really matter.)
      # If the timestamps are the same, nothing to do
      # because rebuild() will ensure that the directory
      # timestamp is the most recent within its
      # entire descent.
      if ( defined ( $when_src && $when_dst) &&
           $when_src == $when_dst ) {
        push @{ $self->{_tracking}->{skipped} }, $dst if $self->{_tracking};
        return;
      }
    }

    print "$dst: Scanning...\n" if $self->{verbose};

    # I know the source is a directory.
    # I know the destination is also a directory
    # which has a different timestamp than the
    # source.  All nodes within both directories
    # must be scanned and updated accordingly.

    my ($handle, $node, %nodes);

    $handle = do { local *FH; };
    $0 = "$self->{proctitle} - src: $src" if $self->{proctitle};
    return unless opendir($handle, $src);
    while (defined ($node = readdir($handle))) {
      next if $node =~ /^\.\.?$/;
      next if $self->{ignore}->{$node};
      next if ($self->{localmode} &&
               !-l "$src/$node" &&
               -d _);
      $nodes{$node} = 1;
      $self->_op if $self->{_gentle_percent};
    }
    closedir($handle);

    $handle = do { local *FH; };
    $0 = "$self->{proctitle} - dst: $dst" if $self->{proctitle};
    return unless opendir($handle, $dst);
    while (defined ($node = readdir($handle))) {
      next if $node =~ /^\.\.?$/;
      next if $self->{ignore}->{$node};
      next if ($self->{localmode} &&
               !-l "$src/$node" &&
               -d _);
      $nodes{$node} = 1;
      $self->_op if $self->{_gentle_percent};
    }
    closedir($handle);

    $0 = "$self->{proctitle} - syncing: $src => $dst" if $self->{proctitle};
    # %nodes is now a union set of all nodes
    # in both the source and destination.
    # Recursively call myself for each node.
    foreach $node (keys %nodes) {
      $self->_dirsync("$src/$node", "$dst/$node");
    }
    # Force permissions to match the source
    chmod( $stat_src[2] & 0777, $dst) or warn "$dst: Failed to chmod: $!\n";
    # Force user and group ownership to match the source
    chown( $stat_src[4], $stat_src[5], $dst) or warn "$dst: Failed to chown: $!\n";
    # Force timestamp to match the source.
    utime $when_src, $when_src, $dst or warn "$dst: Failed to utime: $!\n";
    $self->_op(5) if $self->{_gentle_percent};
    return;
  }

  print "$src: Unimplemented weird type of file! Skipping...\n" if $self->{verbose};
}

sub only {
  my $self = shift;
  push (@{ $self->{only} }, @_);
}

sub maxskew {
  my $self = shift;
  $self->{maxskew} = shift || 0;
}

sub dst {
  my $self = shift;
  $self->{dst} = shift;
}

sub src {
  my $self = shift;
  $self->{src} = shift;
}

sub ignore {
  my $self = shift;
  $self->{ignore} ||= {};
  # Load ignore into a hash
  foreach my $node (@_) {
    $self->{ignore}->{$node} = 1;
  }
}

sub lockfile {
  my $self = shift;
  my $lockfile = shift or return;
  open (LOCK, ">$lockfile") or return;
  if (!flock(LOCK, 6)) { # (LOCK_EX | LOCK_NB)
    print "Skipping due to concurrent process already running.\n" if $self->{verbose};
    exit;
  }
}

sub verbose {
  my $self = shift;
  if (@_) {
    $self->{verbose} = shift;
  }
  return $self->{verbose};
}

sub localmode {
  my $self = shift;
  if (@_) {
    $self->{localmode} = shift;
  }
  return $self->{localmode};
}

sub nocache {
  my $self = shift;
  if (@_) {
    $self->{nocache} = shift;
  }
  return $self->{nocache};
}


sub entries_updated {
  my $self = shift;
  return () unless ( ref $self->{_tracking} eq 'HASH' );
  return @{ $self->{_tracking}->{updated} };
}

sub entries_removed {
  my $self = shift;
  return () unless ( ref $self->{_tracking} eq 'HASH' );
  return @{ $self->{_tracking}->{removed} };
}

sub entries_skipped {
  my $self = shift;
  return () unless ( ref $self->{_tracking} eq 'HASH' );
  return @{ $self->{_tracking}->{skipped} };
}

sub entries_failed {
  my $self = shift;
  return () unless ( ref $self->{_tracking} eq 'HASH' );
  return @{ $self->{_tracking}->{failed} };
}

sub rmtree {
  my $self = shift;
  my $restore = {};
  foreach my $node (@_) {
    $self->_op if $self->{_gentle_percent};
    my (undef,undef,$mode) = lstat $node;
    if (-d _) {
      my @files = ();
      if (opendir my $d, $node) {
        @files = readdir $d;
        closedir $d;
      } else {
        unless ($mode & 0200) {
          # Make directory writable
          chmod 0777, $node or warn "$node: Failed to chmod: $!\n";
          $self->_op(2) if $self->{_gentle_percent};
          # Try to opendir one last time
          if (opendir my $d, $node) {
            @files = readdir $d;
            closedir $d;
          } else {
            warn "$node: Failed to opendir: $!\n";
          }
        }
      }
      $self->rmtree( map { "$node/$_" } grep !/^\.\.?$/, @files );
      rmdir $node;
      $self->_op(3 + scalar(@files)) if $self->{_gentle_percent};
    } else {
      if (!unlink $node and lstat $node) {
        # Tried to unlink it but it still exists
        my $dir = $node;
        $dir =~ s%[^/]*$%.%;
        my (undef,undef, $dmode) = lstat $dir;
        unless ($dmode & 0200) {
          # Make directory writable
          chmod 0777, $dir or warn "$dir: Failed to chmod: $!\n";
          $self->_op if $self->{_gentle_percent};
        }
        # Try one last time to remove
        unlink $node or warn "$node: Failed to unlink: $!\n";
        $self->_op(4) if $self->{_gentle_percent};
        # Don't forget to restore this guy back to how he was
        $restore->{$dir} = $dmode & 07777 unless exists $restore->{$dir};
      } else {
        $self->_op if $self->{_gentle_percent};
      }
    }
  }
  foreach my $dir (keys %{ $restore }) {
    chmod $restore->{$dir}, $dir;
  }
  $self->_op(1 + scalar(keys %{ $restore }) ) if $self->{_gentle_percent};
  return $_[0] && !lstat $_[0];
}

# Create copy of $src as $dst in one atomic operation.
# (The $dst file will never be partial.)
sub copy {
  my $self = shift;
  my $src = shift;
  my $dst = shift;
  my $temp_dst = $dst;
  $temp_dst =~ s%/([^/]+)$%/.\#$1.dirsync.tmp%;
  my $errno = 0;
  if (sysopen FROM, $src, O_RDONLY) {
    if (sysopen TO, $temp_dst, O_WRONLY | O_CREAT | O_EXCL, 0600) {
      my $buffer;
      while (sysread(FROM, $buffer, BUFSIZE)) {
        $self->_op(BUFFER_OPS) if $self->{_gentle_percent};
        if (!syswrite(TO, $buffer, length $buffer)) {
          $errno = $!;
          last;
        }
      }
      close TO;
    } else {
      $errno = $!;
    }
    close FROM;
  } else {
    $errno = $!;
  }
  # XXX - Should we consider this operation as many thousands of ops?
  # XXX - Depending on fs type, such as reiserfs, could this grind?
  if (!$errno and !rename $temp_dst, $dst) {
    $errno = $!;
  }
  $self->_op(6) if $self->{_gentle_percent};
  if ($errno) {
    unlink $temp_dst;
    $! = $errno;
    return undef;
  }
  return 1;
}

1;
__END__