ged

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

# Copyright 1998-2003, 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.12 - 2nd February 2003

use strict;

require 5.005;

use diagnostics;

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

use Gedcom 1.12;

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

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