File Coverage

blib/lib/File/DirCompare.pm

Criterion	Covered	Total	%
statement	64	65	98.4
branch	40	52	76.9
condition	15	21	71.4
subroutine	11	11	100.0
pod	0	2	0.0
total	130	151	86.0

package File::DirCompare;

use 5.005;
use strict;

use File::Basename;
use File::Spec::Functions;
use File::Compare ();
use File::Glob qw(bsd_glob);
use Carp;

use vars qw($VERSION);

$VERSION = '0.7';

# ----------------------------------------------------------------------------
# Private methods

sub _dir_compare
{
  my $self = shift;
  my ($dir1, $dir2, $sub, $opts) = @_;

  # Glob $dir1 and $dir2
  my (%d1, %d2);
  $d1{basename $_} = 1 foreach bsd_glob(catfile($dir1, ".*"));
  $d1{basename $_} = 1 foreach bsd_glob(catfile($dir1, "*"));
  $d2{basename $_} = 1 foreach bsd_glob(catfile($dir2, ".*"));
  $d2{basename $_} = 1 foreach bsd_glob(catfile($dir2, "*"));

  # Prune dot dirs
  delete $d1{curdir()} if $d1{curdir()};
  delete $d1{updir()}  if $d1{updir()};
  delete $d2{curdir()} if $d2{curdir()};
  delete $d2{updir()}  if $d2{updir()};

  # Setup cmp and matches subs
  my $cmp = $opts->{cmp} && ref $opts->{cmp} eq 'CODE' ? $opts->{cmp} : \&File::Compare::compare;
  my $matches = $opts->{matches} if $opts->{matches} && ref $opts->{matches} eq 'CODE';

  # Iterate over sorted and uniquified file list
  my %u;
  for my $f (map { $u{$_}++ == 0 ? $_ : () } sort(keys(%d1), keys(%d2))) {
    my $f1 = catfile($dir1, $f);
    my $f2 = catfile($dir2, $f);
    # Only in $dir1
    if (! $d2{$f}) {
      $sub->($f1, undef) unless $opts->{ignore_unique};
    }
    # Only in $dir2
    elsif (! $d1{$f}) {
      $sub->(undef, $f2) unless $opts->{ignore_unique};
    }
    # Item exists in both directories
    else {
      # Both symlinks
      if (-l $f1 && -l $f2) {
        my $t1 = readlink $f1 or croak "Cannot read symlink $f1: $!";
        my $t2 = readlink $f2 or croak "Cannot read symlink $f2: $!";
        $sub->($f1, $f2) if $t1 ne $t2;
      }
      # One symlink (i.e. different)
      elsif (-l $f1 || -l $f2) {
        $sub->($f1, $f2);
      }
      # Both directories
      elsif (-d $f1 && -d $f2) {
        $self->_dir_compare($f1, $f2, $sub, $opts);
      }
      # One directory (i.e. different)
      elsif (-d $f1 || -d $f2) {
        $sub->($f1, $f2);
      }
      # Both files - check if different
      else {
        if ($opts->{ignore_cmp}) {
          $sub->($f1, $f2);
        }
        elsif ($cmp->($f1, $f2) != 0) {
          $sub->($f1, $f2);
        }
        elsif ($matches) {
          $matches->($f1, $f2);
        }
      }
    }
  }
}

# ----------------------------------------------------------------------------
# Public methods

sub compare
{
  my $self = shift;
  my ($dir1, $dir2, $sub, $opts) = @_;

  croak "Not a directory: '$dir1'" unless -d $dir1;
  croak "Not a directory: '$dir2'" unless -d $dir2;
  croak "Not a subroutine: '$sub'" unless ref $sub eq 'CODE';
  croak "Not a hashref: '$opts'" if $opts && ref $opts ne 'HASH';

  $self = $self->new unless ref $self;
  $self->_dir_compare(@_);
}

# ----------------------------------------------------------------------------
# Constructors

sub new { bless {}, shift }

# ----------------------------------------------------------------------------

1;

__END__