#!/usr/local/bin/perl -w

# Copyright 1998-2005, Paul Johnson (pjcj@cpan.org)

# 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.1502 - 20th December 2005

use strict;

require 5.005;

use diagnostics;

use Data::Dumper;
$Data::Dumper::Indent = 1;

use Gedcom 1.1502;

use vars qw( $VERSION );
$VERSION = "1.1502";

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 => 0.1,
    # grammar_file    => "gedcom-5.5.aft.grammar",
    # callback        => sub { print "." },
    # read_only       => 1,
  );
  if (1)
  {
      $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);
  }
  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");
  }
}

main