/usr/share/perl5/Gedcom/Comparison.pm

# Copyright 2003-2013, Paul Johnson (paul@pjcj.net)

# This software is free.  It is licensed under the same terms as Perl itself.

# The latest version of this software should be available from my homepage:
# http://www.pjcj.net

# documentation at __END__

use strict;

require 5.005;

package Gedcom::Comparison;

use vars qw($VERSION $Indent);
$VERSION = "1.19";
$Indent  = 0;

BEGIN { eval "use Date::Manip" }             # We'll use this if it is available

use Gedcom::Item 1.19;

my %cache;

sub new
{
  my $class     = shift;
  my ($r1, $r2) = @_;
  $r1           = "" unless defined $r1;
  $r2           = "" unless defined $r2;

  my $key ="$r1--$r2";

  return $cache{$key} if exists $cache{$key};

  my $self =
  {
    record1 => $r1,
    record2 => $r2,
  };

  bless $self, $class;

  if (!%cache && !$INC{"Date/Manip.pm"})
  {
    warn "Date::Manip.pm may be required to accurately compare dates\n";
  }

  $cache{$key} = $self->_compare
}


sub _compare
{
  my $self = shift;

  $self->{$_} = [] for qw( identical conflict only1 only2 );

  my $r1 = $self->{record1};
  my $r2 = $self->{record2};

  my ($v1, $v2) = ($r1->{value}, $r2->{value});

  # The values match if neither record has a value, or if both do and
  # they are the same.

  if (0)
  {
      $self->{value_match} = !(defined $v1 ^ defined $v2);
      $self->{value_match} &&= $v1 eq $v2 if defined $v1;
  }
  else
  {
      if ($r1->tag eq "DATE")
      {
          my $err;
          my $d = DateCalc($v1, $v2, \$err, 1);
          print "**** [$v1] [$v2] $d\n";
          my @d = split ":", $d;
          $self->{value_match} = grep (!($_ + 0), @d) / @d;
      }
      else
      {
          $self->{value_match} = !(defined $v1 ^ defined $v2);
          $self->{value_match} &&= $v1 eq $v2 if defined $v1;
      }
  }

  my @r1 = $r1 && UNIVERSAL::isa($r1, "Gedcom::Item") ? $r1->items : ();
  my @r2 = $r2 && UNIVERSAL::isa($r2, "Gedcom::Item") ? $r2->items : ();

  TAG1:
  for my $i1 (@r1)
  {
    my $tag       = $i1->tag;
    my @match     = (-1, -1);
    for my $i2 (0 .. $#r2)
    {
      next unless $r2[$i2]->tag eq $tag;
      my $comp = Gedcom::Comparison->new($i1, $r2[$i2]);  # TODO memoise
      my $m    = $comp->match;
      @match   = ($i2, $m, $comp) if $m > $match[1];
    }

    if ($match[2])
    {
      push @{$self->{$match[2]->identical ? "identical" : "conflict"}},
           $match[2];
      splice @r2, $match[0], 1;
      next
    }

    push @{$self->{only1}}, $i1;
  }

  $self->{only2} = \@r2;

  $self
}


sub identical
{
  my $self = shift;
  $self->match == 100
}

sub match
{
  my $self = shift;
  $self->{match} =
    100 *
    ($self->{value_match} + @{$self->{identical}}) /
    (1                    + @{$self->{identical}}
                          + @{$self->{conflict}}
                          + @{$self->{only1}}
                          + @{$self->{only2}})
    unless exists $self->{match};
  $self->{match}
}

sub print
{
  my $self = shift;

  local $Indent = $Indent + 1;
  my $i = "  " x ($Indent - 1);

  print $self->identical ? $i : "${i}not ";
  print "identical\n";

  printf "${i}match:       %5.2f%%\n", $self->match;
  printf "${i}value match: %d\n",      $self->{value_match};
  printf "${i}identical:   %d\n",      scalar @{$self->{identical}};
  printf "${i}conflict:    %d\n",      scalar @{$self->{conflict}};
  printf "${i}only1:       %d\n",      scalar @{$self->{only1}};
  printf "${i}only2:       %d\n",      scalar @{$self->{only2}};

  print "${i}record 1:\n";
  $self->{record1}->print;
  print "${i}record 2:\n";
  $self->{record2}->print;

  print "${i}conflicts:\n";
  my $c;
  print($i, ++$c, ":\n"), $_->print for @{$self->{conflict}};
}

1;

__END__

=head1 NAME

Gedcom::Comparison - a module to compare Gedcom records

Version 1.19 - 18th August 2013

=head1 SYNOPSIS

  use Gedcom::Comparison;

=head1 DESCRIPTION

=head1 METHODS

=cut
libgedcom-perl 1.19-1 / usr / share / perl5 / Gedcom / Comparison.pm
