Revision 35

Date:
2006/05/28 20:39:43
Author:
pjcj
Revision Log:
Allow comparisons to compare dates in different formats.
Files:

Legend:

 
Added
 
Removed
 
Modified

  • trunk/CHANGES

     
    1 1 Gedcom.pm history
    2 2
    3 3 Release 1.16 -
    4 - Allow fammily to be undef in children_statement in lines2perl.
    4 - Allow family to be undef in children_statement in lines2perl.
    5 5
    6 6 Release 1.15 - 3rd May 2005
    7 7 - Update mailing list information.

  • trunk/ged

     
    44 44 );
    45 45 if (1)
    46 46 {
    47 $ged = Gedcom->new(grammar_version => 5.5 );
    48 my $record=$ged->add_source();
    49 my $obje=$record->add("obje");
    50 $obje->add("form", "png");
    51 $obje->add("file", "somefile");
    52 $ged->write("$gedcom_file.new");
    53 }
    54 if (0)
    55 {
    47 56 my $i = $ged->get_individual("I1");
    48 57 print "NOTE [", exists $i->get_record("note")->{grammar}{value}, "]\n";
    49 58 print "BIRT [", exists $i->get_record("birt")->{grammar}{value}, "]\n";

  • trunk/gedcom_compare

     
    46 46 );
    47 47 print "\n";
    48 48
    49 my $comparison = $ged1->{record}->compare($ged2->{record});
    50 # my $comparison = $ged1->get_individual("I1")->compare($ged2->get_individual("I2"));
    49 # my $comparison = $ged1->{record}->compare($ged2->{record});
    50 my $comparison = $ged1->get_individual("I1")->compare($ged2->get_individual("I0003"));
    51 51
    52 52 $comparison->print;
    53 53 # print Dumper $comparison;

  • trunk/lib/Gedcom.pm

     
    383 383
    384 384 sub write_xml
    385 385 {
    386 my $self = shift;
    387 my $file = shift or die "No filename specified";
    386 my $self = shift;
    387 my $file = shift or die "No filename specified";
    388 388 $self->{fh} = FileHandle->new($file, "w") or die "Can't open $file: $!";
    389 389 $self->{fh}->print(<<'EOH');
    390 390 <?xml version="1.0" encoding="utf-8"?>

  • trunk/lib/Gedcom/Comparison.pm

     
    17 17 $VERSION = "1.1502";
    18 18 $Indent = 0;
    19 19
    20 BEGIN { eval "use Date::Manip" } # We'll use this if it is available
    21
    20 22 use Gedcom::Item 1.1502;
    21 23
    22 24 my %cache;
    … …  
    25 27 {
    26 28 my $class = shift;
    27 29 my ($r1, $r2) = @_;
    30 $r1 = "" unless defined $r1;
    31 $r2 = "" unless defined $r2;
    28 32
    29 33 my $key ="$r1--$r2";
    30 34
    … …  
    38 42
    39 43 bless $self, $class;
    40 44
    45 if (!%cache && !$INC{"Date/Manip.pm"})
    46 {
    47 warn "Date::Manip.pm may be required to accurately compare dates\n";
    48 }
    49
    41 50 $cache{$key} = $self->_compare
    42 51 }
    43 52
    … …  
    51 60 my $r1 = $self->{record1};
    52 61 my $r2 = $self->{record2};
    53 62
    63 my ($v1, $v2) = ($r1->{value}, $r2->{value});
    64
    54 65 # The values match if neither record has a value, or if both do and
    55 66 # they are the same.
    56 67
    57 my ($v1, $v2) = ($r1->{value}, $r2->{value});
    58 $self->{value_match} = !(defined $v1 ^ defined $v2);
    59 $self->{value_match} &&= $v1 eq $v2 if defined $v1;
    68 if (0)
    69 {
    70 $self->{value_match} = !(defined $v1 ^ defined $v2);
    71 $self->{value_match} &&= $v1 eq $v2 if defined $v1;
    72 }
    73 else
    74 {
    75 if ($r1->tag eq "DATE")
    76 {
    77 my $err;
    78 my $d = DateCalc($v1, $v2, \$err, 1);
    79 print "**** [$v1] [$v2] $d\n";
    80 my @d = split ":", $d;
    81 $self->{value_match} = grep (!($_ + 0), @d) / @d;
    82 }
    83 else
    84 {
    85 $self->{value_match} = !(defined $v1 ^ defined $v2);
    86 $self->{value_match} &&= $v1 eq $v2 if defined $v1;
    87 }
    88 }
    60 89
    61 my @r1 = $r1->items;
    62 my @r2 = $r2->items;
    90 my @r1 = $r1 && UNIVERSAL::isa($r1, "Gedcom::Item") ? $r1->items : ();
    91 my @r2 = $r2 && UNIVERSAL::isa($r2, "Gedcom::Item") ? $r2->items : ();
    63 92
    64 93 TAG1:
    65 94 for my $i1 (@r1)
    … …  
    76 105
    77 106 if ($match[2])
    78 107 {
    79 push @{$self->{$match[2]->identical ? "identical" : "conflict"}}, $match[2];
    108 push @{$self->{$match[2]->identical ? "identical" : "conflict"}},
    109 $match[2];
    80 110 splice @r2, $match[0], 1;
    81 111 next
    82 112 }

  • trunk/lib/Gedcom/Grammar.pm

     
    41 41 my ($tag) = @_;
    42 42 return unless defined $tag;
    43 43 my $valid_items = $self->valid_items;
    44 # use Data::Dumper; print "[$tag] -- ", Dumper($self), Dumper $valid_items;
    44 45 return unless exists $valid_items->{$tag};
    45 46 map { $_->{grammar} } @{$valid_items->{$tag}}
    46 47 }