The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/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