Skip to content

Commit

Permalink
Version 1.02
Browse files Browse the repository at this point in the history
  • Loading branch information
@pjcj
pjcj committed Feb 21, 2005
1 parent 36c030d commit 2829f22
Show file tree
Hide file tree
Showing 19 changed files with 5,792 additions and 371 deletions.
21 changes: 19 additions & 2 deletions CHANGES
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,16 +2,33 @@ Gedcom.pm history

Release 1.00 - Initial release

Release 1.01
Release 1.01 - 27th April 1999
- Add some documentation
- Add Individual.pm and Family.pm
- Remove get_records() - use get_children() instead
- Change get_children() and children() to return a list, rather than a
reference to one
- Add resolve_xref() and resolve()
- Change to profile of collect_xrefs(), resolve_xrefs() and validate()
- Change the profile of collect_xrefs(), resolve_xrefs() and validate()
- Add get_individual()
- Remove redundant Gedcom::Item::renumber()
- Rename child() to child_value() and children() to child_values()
- Improve testsuite
- Make Date::Manip optional

Release 1.02
- Add RIN numbers to royal.ged
- Move test.pl to t/basic.t
- Make basic.t "use Test"
- Add many tests to basic.t
- Add pre-parsed grammar files
- Add grammar target to Makefile.PL
- Add functions to Family.pm and change Individual.pm to use them
- Improve error messages reading top level children
- Change the profile of renumber()
- Internally, remove leading and trailing @ in xrefs
- Change order of renumber() to match documentation
- Get renumber() to call collect_xrefs()
- Add resolve_xref() to Gedcom.pm
- Add next_xref() to Gedcom.pm
- Add unresolve_xrefs() to compliment resolve_xrefs()
176 changes: 136 additions & 40 deletions Gedcom.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16,15 +16,12 @@ package Gedcom;
use Data::Dumper;
use FileHandle;

use Gedcom::Grammar 1.01;
use Gedcom::Individual 1.01;
use Gedcom::Family 1.01;
use Gedcom::Grammar 1.02;
use Gedcom::Individual 1.02;
use Gedcom::Family 1.02;

BEGIN
{
use vars qw($VERSION);
$VERSION = "1.01";
}
use vars qw($VERSION);
$VERSION = "1.02";

sub new
{
Expand All @@ -34,10 +31,24 @@ sub new
bless $self, $class;

# first read in the grammar
return undef unless
my $grammar = $self->{grammar} =
Gedcom::Grammar->new(file => $self->{grammar_file},
callback => $self->{callback});
my $grammar;
if (defined $self->{grammar_file})
{
return undef unless
$grammar = Gedcom::Grammar->new(file => $self->{grammar_file},
callback => $self->{callback});
}
else
{
$self->{grammar_version} = 5.5 unless defined $self->{grammar_version};
(my $v = $self->{grammar_version}) =~ tr/./_/;
my $g = "Gedcom::Grammar_$v";
eval "use $g $VERSION";
die $@ if $@;
no strict "refs";
return undef unless $grammar = ${$g . "::grammar"};
}
$self->{grammar} = $grammar;

my $structures = $grammar->{structures} = $grammar->structures;
my %children = map { $_->{tag} => $_ }
Expand Down Expand Up @@ -70,16 +81,33 @@ sub collect_xrefs
{
my $self = shift;
my ($callback) = @_;
$self->{gedcom}{xrefs} = [];
$self->{record}->collect_xrefs($callback);
}

sub resolve_xref
{
my $self = shift;;
my ($x) = @_;
my $xref;
$xref = $self->{xrefs}{$x =~ /^\@(.*)\@$/ ? $1 : $x} if defined $x;
$xref;
}

sub resolve_xrefs
{
my $self = shift;
my ($callback) = @_;
$self->{record}->resolve_xrefs($callback);
}

sub unresolve_xrefs
{
my $self = shift;
my ($callback) = @_;
$self->{record}->unresolve_xrefs($callback);
}

sub validate
{
my $self = shift;
Expand All @@ -100,27 +128,25 @@ sub normalise_dates
sub renumber
{
my $self = shift;
my ($callback) = @_;
my (%args) = @_;
$self->resolve_xrefs;

# these variables are passed through by reference
my $f = 1;
my $i = 1;

# initially, renumber any records passed in
for my $xref (@_)
for my $xref (@{$args{xrefs}})
{
if (exists $self->{xrefs}{$xref})
{
$self->{xrefs}{$xref}->renumber($f, $i, $callback);
}
$self->{xrefs}{$xref}->renumber(\%args, 1) if exists $self->{xrefs}{$xref};
}

# now, renumber any records left over
for my $child (@{$self->{record}{children}})
{
$child->renumber($f, $i, $callback);
}
$_->renumber(\%args, 1) for (@{$self->{record}{children}});

# and remove new_xref so we can do it again
delete @$_{qw(renumbered recursed)} for (@{$self->{record}{children}});

# and update the xrefs
$self->collect_xrefs;

%args
}

sub sort_sub
Expand Down Expand Up @@ -206,6 +232,19 @@ sub get_individual
()
}

sub next_xref
{
my $self = shift;
my ($type) = @_;
my $re = qr/^$type(\d+)$/;
my $last = 0;
for my $c (@{$self->{record}{children}})
{
$last = $1 if exists $c->{xref} and $c->{xref} =~ /$re/ and $1 > $last;
}
$type . ++$last
}

1;

__END__
Expand All @@ -214,23 +253,30 @@ __END__
Gedcom - a class to manipulate Gedcom genealogy files
Version 1.01 - 27th April 1999
Version 1.02 - 5th May 1999
=head1 SYNOPSIS
use Gedcom;
my $ged = Gedcom->new(gedcom_file => $gedcom_file);
my $ged = Gedcom->new(grammar_version => 5.5,
gedcom_file => $gedcom_file,
callback => $cb);
my $ged = Gedcom->new(grammar_file => "gedcom-5.5.grammar",
gedcom_file => $gedcom_file);
return unless $ged->validate;
my $xref = $self->resolve_xref($value)
$ged->resolve_xrefs;
$ged->unresolve_xrefs;
$ged->normalise_dates;
$ged->renumber;
my %xrefs = $ged->renumber;
$ged->order;
$ged->write($new_gedcom_file);
my @individuals = $ged->individuals;
my @families = $ged->families;
my ($me) = $ged->get_individual("Paul Johnson");
my $xref = $ged->next_xref("I");
=head1 DESCRIPTION
Expand Down Expand Up @@ -261,8 +307,8 @@ suppose this is the virtue of laziness shining through.
The vice of laziness is also shining brightly - I need to document how
to use this module in much greater detail. This is happening - this
release has more docuemntation than previously - but if you would like
information feel free to send me mail.
release has more docuemntation than the previous ones - but if you would
like information feel free to send me mail.
This module provides some functions which work over the entire Gedcom
file, such as reformatting dates, renumbering entries and ordering the
Expand Down Expand Up @@ -314,18 +360,41 @@ See Gedcom::Record.pm for more details.
=head2 new
my $ged = Gedcom->new(gedcom_file => $gedcom_file);
my $ged = Gedcom->new(grammar_version => 5.5,
gedcom_file => $gedcom_file,
callback => $cb);
my $ged = Gedcom->new(grammar_file => "gedcom-5.5.grammar",
gedcom_file => $gedcom_file);
Create a new gedcom object.
grammar_file must be the name of a gedcom grammar file. I have only
used and tested with this 5.5 grammar. You'll probably have to put the
grammar file somewhere safe and hard code the path. I'll look into
doing something better later.
gedcom_file is the name of the gedcom file to parse.
You may optionally pass grammar_version as the version number of the
gedcom grammar you want to use. At the moment only version 5.5 is
available. If you do not specify a grammar version, you may specify a
grammar file as grammar_file. Usually, you will do neither of these,
and in this case the grammar version will default to the latest
available version, currently 5.5.
callback is an optional reference to a subroutine which will be called
at various times while the gedcom file (and the grammar file, ir
applicable) is being read. It's purpose is to provide feedback during
potentially long operations. The subroutine is called with five
arguments:
my ($title, $txt1, $txt2, $current, $total) = @_;
$title is a brief description of the current operation
$txt1 and $txt2 provide more information on the current operation
$current is the number of operations performed
$total is the number of operations that need to be performed
If the subroutine returns false, the operation is aborted.
=head2 write
$ged->write($new_gedcom_file);
Expand All @@ -343,6 +412,12 @@ location. $callback is not used yet.
Called by new().
=head2 resolve_xref
my $xref = $self->resolve_xref($value)
Return the record $value points to, or undef.
=head2 resolve_xrefs
$ged->resolve_xrefs($callback)
Expand All @@ -351,6 +426,14 @@ Changes all xrefs to reference the record they are pointing to. Like
changing a soft link to a hard link on a Unix filesystem. $callback is
not used yet.
=head2 unresolve_xrefs
$ged->unresolve_xrefs($callback)
Changes all xrefs to name the record they contained. Like changing a
hard link to a soft link on a Unix filesystem. $callback is not used
yet.
=head2 validate
return unless $ged->validate($callback)
Expand All @@ -376,14 +459,21 @@ programs don't like that format.
=head2 renumber
$ged->renumber;
$ged->renumber($xref1, $xref2, ...);
my %xrefs = $ged->renumber(INDI => 34, FAM => 12, xrefs => [$xref1, $xref2]);
Renumber all the records. Optionally provide a list of records to start
with.
Renumber all the records.
Optional parameters are:
tag name => last used number (defaults to 0)
xrefs => list of xrefs to renumber first
As a record is renumbered, it is assigned the next available number.
The husband, wife and children are then renumbered. This helps to
ensure that families are numerically close together.
The husband, wife, children parents and siblings are then renumbered in
that order. This helps to ensure that families are numerically close
together.
The hash returned is the updated hash that was passed in.
=head2 sort_sub
Expand Down Expand Up @@ -440,4 +530,10 @@ The matches are:
9 - Names in any order, on word boundaries, case insensitive
10 - Names in any order, anywhere, case insensitive
=head2 next_xref
my $xref = $ged->next_xref("I");
Return the next available xref with the specified prefix.
=cut
Loading

0 comments on commit 2829f22

Please sign in to comment.