#!/usr/local/bin/perl -w
# Copyright 1998-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
# Version 1.20 - 17th September 2017
use strict;
require 5.005;
use diagnostics;
use Data::Dumper;
$Data::Dumper::Indent = 1;
use Gedcom 1.20;
use vars qw( $VERSION );
$VERSION = "1.20";
eval "use Date::Manip";
Date_Init("DateFormat=UK") if $INC{"Date/Manip.pm"};
$SIG{__WARN__} = sub { print STDERR "\n@_" };
sub main {
my $gedcom_file = shift @ARGV;
$| = 1;
print "reading...";
my $ged = Gedcom->new(
$gedcom_file,
# gedcom_file => $gedcom_file,
# grammar_version => "5.5.1",
# grammar_file => "gedcom-5.5.1.grammar",
# callback => sub { print "." },
# read_only => 1,
);
if (0) {
my $i = $ged->get_individual("I1");
my $n2 = $ged->add_note({ xref => "NN2" }, "top level");
$n2->add("cont", "line 2");
my $note1 = $i->add("note", "qaz");
$note1->add("cont", "q2");
my $note2 = $i->add("note", $n2);
$note2->add("cont", "q3");
$ged->order;
print "\nvalidating...";
$ged->validate;
print "\nwriting...";
$ged->write("$gedcom_file.new");
}
if (0) {
my $i = $ged->get_individual("I1");
my $obj1 = $i->add("OBJE", 12);
# use DDS; print STDERR Dump $obj;
my $obj2 = $i->add("OBJE");
$obj2->add("FORM", "qqq");
$obj2->add("FILE", "rrr");
print "\nvalidating...";
$ged->validate;
print "\nwriting...";
$ged->write("$gedcom_file.new");
}
if (0) {
$ged = Gedcom->new(grammar_version => 5.5 );
my $record=$ged->add_source();
my $obje=$record->add("obje");
$obje->add("form", "png");
$obje->add("file", "somefile");
$ged->write("$gedcom_file.new");
}
if (0) {
my $i = $ged->get_individual("I1");
print "NOTE [", exists $i->get_record("note")->{grammar}{value}, "]\n";
print "BIRT [", exists $i->get_record("birt")->{grammar}{value}, "]\n";
}
if (0) {
# use DDS; print STDERR Dump $ged;
my $i = $ged->get_individual("I8");
print $i->{grammar}->valid_items->{NAME}[0]{max};
print $i->{grammar}->valid_items->{SEX}[0]{max};
print "\n";
for ($i->items) {
my $t = $_->{tag};
my $vi = $i->{grammar}->valid_items;
print "$t: $vi->{$t}[0]{min} - $vi->{$t}[0]{max}\n";
}
}
if (0) {
print "\nchanging BIRT to CHR...";
my $i = $ged->get_individual("I8");
for ($i->items) {
$_->{tag} = "CHR" if $_->{tag} eq "BIRT";
}
$ged->validate;
print "\nwriting...";
$ged->write("$gedcom_file.new");
}
if (0) {
$ged->resolve_xrefs;
print "\nmerging notes...";
my @notes = grep $_->tag eq "NOTE", $ged->{record}->items;
my %notes;
my @dups;
for my $note (@notes) {
my $text = $note->full_value;
if (exists $notes{$text}) {
print "NOTE ", $note->xref, " matches $notes{$text}\n";
$note->{xref} = $notes{$text};
push @dups, $note;
} else {
$notes{$text} = $note->xref;
}
}
$ged->unresolve_xrefs;
$_->delete for @dups;
$ged->validate;
print "\nwriting...";
$ged->write("$gedcom_file.new");
}
if (0) {
my $age = sub { Date_Cmp(ParseDate($a->get_value("birth date") || ""),
ParseDate($b->get_value("birth date") || "")) };
print "\nrenumbering...";
my @i = sort { $age->($a) <=> $age->($b) } $ged->individuals;
$ged->renumber(xrefs => [ map $_->xref, @i ]);
$ged->validate;
print "\nwriting...";
$ged->write("$gedcom_file.new");
}
if (0) {
# my @i = $ged->get_individual("I8");
# my @i = grep $_->rin == 8, $ged->individuals;
my @i = $ged->individuals;
print "\n", $_->xref, " => ", $_->name, "\n" for @i;
# my $i = shift @i;
my $i = $ged->get_individual("I8");
my $b = $i->birth;
print "[", $i->get_value("fams marriage date"), "]\n";
print "[", $i->fams->marriage->date, "]\n";
print "[", $i->get_value(qw(famc marriage date)), "]\n";
}
if (0) {
my $i = $ged->get_individual("I31");
my $famc = $i->famc;
my $s = $famc->source;
print "source: $s\n";
my ($source) = grep $_->xref eq $s, $ged->{record}->record("source");
print $source->text, "\n";
my $s2 = $ged->get_source($s);
print $s2->text, "\n";
return;
}
if (0) {
system "ps -o user,pid,pgid,pcpu,pmem,vsz,rss,tty,s,stime,time,args " .
"| grep ged";
return;
}
# print Dumper $ged;
# print "\nnormalising dates...";
# $ged->normalise_dates("%E %b %Y");
# sleep 6000;
if (0) {
print "\nwriting xml...";
$ged->write_xml("$gedcom_file.xml");
}
if (1) {
print "\nvalidating...";
my %x;
my $vcb = sub {
my ($r) = @_;
my $t = $r->{xref};
print "." if $t && !$x{$t}++;
};
$ged->validate($vcb);
print "\nwriting...";
$ged->write("$gedcom_file.new");
print "\n";
}
if (@ARGV) {
print "\n---" . localtime();
my $i = $ged->get_individual(shift @ARGV);
print "\n", $i->xref, " => ", $i->name, "\n---" . localtime() . "\n";
# my $n = $i->get_record("note");
# print "\n", ($n || "undef"), ", ", $i->note, "\n";
# print "\n", $n->xref, " => ", $n->value, "\n";
}
if (0) {
print "\nnormalising dates...";
$ged->normalise_dates("%E %b %Y");
# $ged->normalise_dates;
print "\nrenumbering...";
$ged->renumber;
print "\nordering...";
$ged->order;
if (0) {
print "\nadding rins...";
my $rin = 1;
for (@{$ged->{record}->_items}) {
push @{$_->{items}}, $_->new(tag => "RIN", value => $rin++)
unless $_->{tag} eq "HEAD" || $_->{tag} eq "TRLR";
}
}
$ged->unresolve_xrefs;
print "\nvalidating...";
$ged->validate;
print "\nwriting...";
$ged->write("$gedcom_file.new");
}
if (0) {
for my $i ($ged->individuals) {
my @residence = $i->residence;
for my $r (@residence) {
print $i->name, ": ", $r->place, "\n";
}
}
}
if (1) {
my $i = $ged->get_individual("I93");
my $prim = $i->get_value("_PRIM");
print "_PRIM: $prim\n";
}
}
main