NAME
Gedcom::Record - a class to manipulate Gedcom records
Version 1.03 - 13th May 1999
SYNOPSIS
use Gedcom::Record;
$self->parse($record, $grammar)
$record->collect_xrefs($callback)
my $xref = $self->resolve_xref($self->{value})
my @famc = $self->resolve($self->child_values("FAMC"))
$record->resolve_xrefs($callback)
$record->unresolve_xrefs($callback)
return 0 unless $child->validate_semantics;
$record->renumber($args);
my $child = $record->child_value("NAME");
my @children = $record->child_values("CHIL");
print $record->summary, "\n";DESCRIPTION
A selection of subroutines to handle records in a gedcom file.
Derived from Gedcom::Item.
HASH MEMBERS
Some of the more important hash members are:
$record->{renumbered}
Used by renumber().
$record->{recursed}
Used by renumber().
METHODS
parse
$self->parse($record, $grammar)Parse a Gedcom record.
Match a Gedcom::Record against a Gedcom::Grammar. Warn of any mismatches, and associate the Gedcom::Grammar with the Gedcom::Record as $self->{grammar}. Do this recursively.
collect_xrefs
$record->collect_xrefs($callback)Recursively collect all the xrefs. Called by Gedcom::collect_xrefs. $callback is not used yet.
resolve_xref
my $xref = $self->resolve_xref($value)See Gedcom::resolve_xrefs()
resolve
my @famc = $self->resolve $self->child_values("FAMC")For each argument, either return it or, if it an xref, return the referenced record.
resolve_xrefs
$record->resolve_xrefs($callback)See Gedcom::resolve_xrefs()
unresolve_xrefs
$record->unresolve_xrefs($callback)See Gedcom::unresolve_xrefs()
validate_semantics
return 0 unless $child->validate_semantics;Validate the semantics of the Gedcom::Record. This performs a number of consistency checks, but could do even more.
Returns true iff the Record is valid.
renumber
$record->renumber($args);Renumber the record.
See Gedcom::renumber().
child_value
my $child = $record->child_value("NAME");Return the value of the specified child, or undef if the child could not be found. Calls get_child().
child_values
my @children = $record->child_values("CHIL");Return a list of the values of the specified children. Calls get_children().
summary
print $record->summary, "\n";Return a line of text summarising the record.
use as: my @children = @{$ged->{record}{children}}; my ($m, $w) = $ged->{record}->validate_structure($ged->{record}{grammar}, \@children, 1); warn $w if $w;
sub validate_grammar { my $self = shift; my ($grammar, $children, $all) = @_; $I++; my $min = $grammar->min; my $max = $grammar->max; $all++ unless $max; my $matches = 0; my $warn = ""; my $value = $grammar->{tag}; print " " x $I, " looking for ", $all == 1 ? "all" : $max if $D; if ($value) { print " $value, $min -> $max\n" if $D; for (my $c = 0; $c <= $#$children && ($all == 1 || !$max || $matches < $max);) { if ($children->[$c]{tag} eq $value) { my $w = $children->[$c]->validate_syntax2; $warn .= $w; splice @$children, $c, 1; $matches++; } else { $c++; } } } else { die "What's a " . Data::Dumper->new([$grammar], ["grammar"]) unless ($value) = $grammar->{value} =~ /<<(.*)>>/; die "Can't find $value in gedcom structures" unless my $s = $grammar->structure($value); $grammar->{structure} = $s; print " $value, $min -> $max\n" if $D; my ($m, $w); do { ($m, $w) = $self->validate_structure($s, $children, $all); if ($m) { $matches += $m; $warn .= $w; } } while $m && ($all == 1 || !$max || $matches < $max); } $I--; ($matches, $warn) }
sub validate_structure { my $self = shift; my ($structure, $children, $all) = @_; $all = 0 unless defined $all; $I++; print " " x $I . "validate_structure($structure->{structure}, $all)\n" if $D; my $warn = ""; my $total_matches = 0; for my $child (@{$structure->{children}}) { my $min = $child->min; my $max = $child->max; my ($matches, $w) = $self->validate_grammar($child, $children, $all); $warn .= $w; my $file = $self->{gedcom}{record}{file}; my $value = $child->{tag} || $child->{structure}{structure}; my $msg = "$file:$self->{line}: $self->{tag}" . (defined $self->{xref} ? " $self->{xref} " : "") . " has $matches $value" . ($matches == 1 ? "" : "s"); print " " x $I . "$msg - minimum is $min maximum is $max\n" if $D; if ($structure->{selection}) { if ($matches) { $warn .= "$msg - minimum is $min\n" if $matches < $min; $warn .= "$msg - maximum is $max\n" if $matches > $max && $max; $total_matches += $matches; # only one child is allowed last; } } else { $warn .= "$msg - minimum is $min\n" if $matches < $min; $warn .= "$msg - maximum is $max\n" if $matches > $max && $max; $total_matches = 1 if $matches; # all children are required } } print " " x $I . "returning $total_matches matches\n" if $D; $I--; ($total_matches, $warn) }
sub validate_syntax2 { my $self = shift; $self->{gedcom}{validate_callback}->($self) if defined $self->{gedcom}{validate_callback}; my $children = [ @{$self->{children}} ]; $I++; my $grammar = $self->{grammar}; print " " x $I . "validate_syntax2($grammar->{tag})\n" if $D; my $warn = ""; my $file = $self->{gedcom}{record}{file}; my $here = "$file:$self->{line}: $self->{tag}" . (defined $self->{xref} ? " $self->{xref}" : ""); for my $child (@$children) { print " " x $I . "level $child->{level} on $self->{level}\n" if $D; $warn .= "$here: Can't add level $child->{level} to $self->{level}\n" if $child->{level} > $self->{level} + 1; } for my $child (@{$grammar->{children}}) { my $min = $child->min; my $max = $child->max; my ($matches, $w) = $self->validate_grammar($child, $children, 1); $warn .= $w; my $value = $child->{tag} || $child->{structure}{structure}; my $msg = "$here has $matches $value" . ($matches == 1 ? "" : "s"); print " " x $I . "$msg - minimum is $min maximum is $max\n" if $D; $warn .= "$msg - minimum is $min\n" if $matches < $min; $warn .= "$msg - maximum is $max\n" if $matches > $max && $max; } if (@$children) { my %tags = map { $_ => 1 } $grammar->children; for my $c (@$children) { my $tag = $c->{tag}; my $msg = exists $tags{$tag} ? "an extra" : "not a"; $warn .= "$file:$c->{line}: $tag is $msg child of $self->{tag}\n" unless $tag eq "CONT" || $tag eq "CONC" || substr($tag, 0, 1) eq "_"; } } $I--; $warn }