File Coverage

blib/lib/Gedcom/Comparison.pm
Criterion Covered Total %
statement 13 89 14.6
branch 0 28 0.0
condition 0 12 0.0
subroutine 5 10 50.0
pod 0 4 0.0
total 18 143 12.5


line stmt bran cond sub pod time code
1             # Copyright 2003-2019, Paul Johnson (paul@pjcj.net)
2              
3             # This software is free. It is licensed under the same terms as Perl itself.
4              
5             # The latest version of this software should be available from my homepage:
6             # http://www.pjcj.net
7              
8             # documentation at __END__
9              
10 11     11   103 use strict;
  11         22  
  11         514  
11              
12             require 5.005;
13              
14             package Gedcom::Comparison;
15              
16 11     11   76 use vars qw($VERSION $Indent);
  11         16  
  11         653  
17             $VERSION = "1.21";
18             $Indent = 0;
19              
20 11     11   561 BEGIN { eval "use Date::Manip" } # We'll use this if it is available
  11     11   69  
  11         21  
  11         1486  
21              
22 11     11   66 use Gedcom::Item 1.21;
  11         143  
  11         8775  
23              
24             my %cache;
25              
26             sub new {
27 0     0 0   my $class = shift;
28 0           my ($r1, $r2) = @_;
29 0 0         $r1 = "" unless defined $r1;
30 0 0         $r2 = "" unless defined $r2;
31              
32 0           my $key ="$r1--$r2";
33              
34 0 0         return $cache{$key} if exists $cache{$key};
35              
36 0           my $self = {
37             record1 => $r1,
38             record2 => $r2,
39             };
40              
41 0           bless $self, $class;
42              
43 0 0 0       if (!%cache && !$INC{"Date/Manip.pm"}) {
44 0           warn "Date::Manip.pm may be required to accurately compare dates\n";
45             }
46              
47 0           $cache{$key} = $self->_compare
48             }
49              
50              
51             sub _compare {
52 0     0     my $self = shift;
53              
54 0           $self->{$_} = [] for qw( identical conflict only1 only2 );
55              
56 0           my $r1 = $self->{record1};
57 0           my $r2 = $self->{record2};
58              
59 0           my ($v1, $v2) = ($r1->{value}, $r2->{value});
60              
61             # The values match if neither record has a value, or if both do and
62             # they are the same.
63              
64 0           if (0) {
65             $self->{value_match} = !(defined $v1 ^ defined $v2);
66             $self->{value_match} &&= $v1 eq $v2 if defined $v1;
67             } else {
68 0 0         if ($r1->tag eq "DATE") {
69 0           my $err;
70 0           my $d = DateCalc($v1, $v2, \$err, 1);
71             # print "**** [$v1] [$v2] $d\n";
72 0           my @d = split ":", $d;
73 0           $self->{value_match} = grep (!($_ + 0), @d) / @d;
74             } else {
75 0           $self->{value_match} = !(defined $v1 ^ defined $v2);
76 0 0 0       $self->{value_match} &&= $v1 eq $v2 if defined $v1;
77             }
78             }
79              
80 0 0 0       my @r1 = $r1 && UNIVERSAL::isa($r1, "Gedcom::Item") ? $r1->items : ();
81 0 0 0       my @r2 = $r2 && UNIVERSAL::isa($r2, "Gedcom::Item") ? $r2->items : ();
82              
83             TAG1:
84 0           for my $i1 (@r1) {
85 0           my $tag = $i1->tag;
86 0           my @match = (-1, -1);
87 0           for my $i2 (0 .. $#r2) {
88 0 0         next unless $r2[$i2]->tag eq $tag;
89 0           my $comp = Gedcom::Comparison->new($i1, $r2[$i2]); # TODO memoise
90 0           my $m = $comp->match;
91 0 0         @match = ($i2, $m, $comp) if $m > $match[1];
92             }
93              
94 0 0         if ($match[2]) {
95 0 0         push @{$self->{$match[2]->identical ? "identical" : "conflict"}},
  0            
96             $match[2];
97 0           splice @r2, $match[0], 1;
98             next
99 0           }
100              
101 0           push @{$self->{only1}}, $i1;
  0            
102             }
103              
104 0           $self->{only2} = \@r2;
105              
106 0           $self
107             }
108              
109              
110             sub identical {
111 0     0 0   my $self = shift;
112 0           $self->match == 100
113             }
114              
115             sub match {
116 0     0 0   my $self = shift;
117             $self->{match} =
118             100 *
119 0           ($self->{value_match} + @{$self->{identical}}) /
120 0           (1 + @{$self->{identical}}
121 0           + @{$self->{conflict}}
122 0           + @{$self->{only1}}
123 0           + @{$self->{only2}})
124 0 0         unless exists $self->{match};
125             $self->{match}
126 0           }
127              
128             sub print {
129 0     0 0   my $self = shift;
130              
131 0           local $Indent = $Indent + 1;
132 0           my $i = " " x ($Indent - 1);
133              
134 0 0         print $self->identical ? $i : "${i}not ";
135 0           print "identical\n";
136              
137 0           printf "${i}match: %5.2f%%\n", $self->match;
138 0           printf "${i}value match: %d\n", $self->{value_match};
139 0           printf "${i}identical: %d\n", scalar @{$self->{identical}};
  0            
140 0           printf "${i}conflict: %d\n", scalar @{$self->{conflict}};
  0            
141 0           printf "${i}only1: %d\n", scalar @{$self->{only1}};
  0            
142 0           printf "${i}only2: %d\n", scalar @{$self->{only2}};
  0            
143              
144 0           print "${i}record 1:\n";
145 0           $self->{record1}->print;
146 0           print "${i}record 2:\n";
147 0           $self->{record2}->print;
148              
149 0           print "${i}conflicts:\n";
150 0           my $c;
151 0           print($i, ++$c, ":\n"), $_->print for @{$self->{conflict}};
  0            
152             }
153              
154             1;
155              
156             __END__