Permalink
Browse files

Version 1.10

  • Loading branch information...
1 parent af7dbd3 commit 1035bfc9276ff5e787dac128c664dc870de7bc84 @pjcj committed Feb 21, 2005
Showing with 3,560 additions and 1,680 deletions.
  1. +61 −3 CHANGES
  2. +229 −74 Gedcom.pm
  3. +7 −4 Gedcom/CGI.pm
  4. +4 −4 Gedcom/Event.pm
  5. +46 −4 Gedcom/Family.pm
  6. +35 −29 Gedcom/Grammar.pm
  7. +2,348 −1,249 Gedcom/Grammar_5_5.pm
  8. +20 −10 Gedcom/Individual.pm
  9. +115 −30 Gedcom/Item.pm
  10. +81 −51 Gedcom/LifeLines.pm
  11. +231 −59 Gedcom/Record.pm
  12. +1 −0 MANIFEST
  13. +15 −9 Makefile.PL
  14. +24 −18 README
  15. +1 −2 TODO
  16. +4 −4 cgi-bin/gedcom.cgi
  17. +25 −10 ged
  18. +1 −1 gedcom.vim
  19. +23 −23 lines2perl
  20. +8 −5 parse_grammar
  21. +8 −2 royal.ged
  22. +1 −1 session.vim
  23. +18 −10 t/Basic.pm
  24. +4 −4 t/Engine.pm
  25. +4 −4 t/Lines.pm
  26. +2 −2 t/basic.t
  27. +2 −2 t/bias.t
  28. +3 −3 t/birthdates.t
  29. +168 −0 t/ged_create.t
  30. +3 −3 t/lines.t
  31. +1 −2 t/lines/bias
  32. +26 −24 t/lines/bias.plx
  33. +3 −1 t/lines/lines
  34. +2 −1 t/lines/lines.l
  35. +9 −5 t/lines/lines.plx
  36. +11 −11 t/lines/namefreq.plx
  37. +2 −2 t/namefreq.t
  38. +3 −3 t/parse_grammar.t
  39. +2 −2 t/read_only.t
  40. +2 −2 t/resolve.t
  41. +2 −2 t/resolve_read_only.t
  42. +5 −5 tkged
View
64 CHANGES
@@ -149,12 +149,70 @@ Release 1.08 - 8th May 2000
- Allow extra sub-items of a grammar structure.
Release 1.09 - 12th February 2001
- - Improved XML output especially with respect to notes.
- - Quietened some spurious warnings.
- - Fixed some bugs reported by users that I don't recall at the moment.
+ - Improve XML output especially with respect to notes.
+ - Quieten some spurious warnings.
+ - Fix some bugs reported by users that I don't recall at the moment.
- Add index file to speed up read_only option.
- Read files with binmode - keeps Windows happy.
- Correct line numbers of errors.
- Use File::Spec so tests pass under Windows.
- Allow for creation of ppms.
- Added Gedcom::CGI and cgi-bin/gedcom.cgi.
+
+Release 1.10 - 5th March 2002
+ - Correct write_xml() documentation.
+ - Make Gedcom::Grammar::item() return a list of valid items, not just one.
+ - Pick the correct item from the list returned by Gedcom::Grammar::item().
+ - Make Gedcom::Individual::given_names() strip and normalise whitespace.
+ - Don't assume another file won't be read while we are reading files by
+ providing an argument to tell().
+ - Fix Gedcom::Lifelines::parents().
+ - Tidy Gedcom::get_individual() and return all matches from all
+ categories in list context.
+ - Let Gedcom::Item::write() output 0 values correctly.
+ - Let various functions in Gedcom::Record deal with 0 values correctly.
+ - Add a pointer flag to Gedcom::Item along with the corresponding function.
+ - Gedcom::new without a gedcom_file argument will create an empty
+ Gedcom object with mandatory fields filled in.
+ - Add methods to add, delete and change records.
+ - Add functions to:
+ Gedcom.pm:
+ add_record()
+ add_header()
+ add_submitter()
+ add_individual()
+ add_family()
+ add_note()
+ add_repository()
+ add_source()
+ add_trailer()
+ Item.pm:
+ parent()
+ delete()
+ pointer()
+ Record.pm:
+ add_record()
+ add()
+ set()
+ get_and_create()
+ Family.pm:
+ add_husband()
+ add_wife()
+ add_child()
+ - Add t/ged_create.t
+ - Change Gedcom::Record::resolve so that unresolved xrefs do not return
+ undef in list context.
+ - Establish the convention that SUBM xrefs start with SUBM to avoid
+ clashes with SOUR.
+ - Some reeorganisation of the AUTOLOAD functions.
+ - Add baptism and endowment information as default to Gedcom::CGI::indi().
+ - Ensure a grammar knows its version number.
+ - Always add headers and trailers to a Gedcom file if necessary.
+ - Change get_individual to return all matching individuals rather than
+ just those which match in the same category.
+ - A number of fixes to Gedcom::Lifelines.pm, some of which are based on
+ work by Tim Lanfear.
+ - Update copyright.
+ - A little work on the documentation.
+ - Some general tidying up.
+ - A couple of workarounds for bleadperl bugs.
View
303 Gedcom.pm
@@ -1,4 +1,4 @@
-# Copyright 1998-2001, Paul Johnson (pjcj@cpan.org)
+# Copyright 1998-2002, Paul Johnson (pjcj@cpan.org)
# This software is free. It is licensed under the same terms as Perl itself.
@@ -13,16 +13,20 @@ require 5.005;
package Gedcom;
+use Carp;
use Data::Dumper;
use FileHandle;
BEGIN { eval "use Text::Soundex" } # We'll use this if it is available
-use vars qw($VERSION $Tags);
+use vars qw($VERSION $AUTOLOAD %Funcs);
+
+my $Tags;
+my %Top_tag_order;
BEGIN
{
- $VERSION = "1.09";
+ $VERSION = "1.10";
$Tags =
{
@@ -156,12 +160,66 @@ BEGIN
WIFE => "Wife",
WILL => "Will",
};
+
+ %Top_tag_order =
+ (
+ HEAD => 1,
+ SUBM => 2,
+ INDI => 3,
+ FAM => 4,
+ NOTE => 5,
+ REPO => 6,
+ SOUR => 7,
+ TRLR => 8,
+ );
+
+ while (my ($tag, $name) = each (%$Tags))
+ {
+ # print "looking at tag $tag <$name>\n";
+ $Funcs{$tag} = $Funcs{lc $tag} = $tag;
+ if ($name)
+ {
+ $name =~ s/ /_/g;
+ $Funcs{lc $name} = $tag;
+ }
+ }
}
-use Gedcom::Grammar 1.09;
-use Gedcom::Individual 1.09;
-use Gedcom::Family 1.09;
-use Gedcom::Event 1.09;
+sub AUTOLOAD
+{
+ my ($self) = @_; # don't change @_ because of the goto
+ return if $AUTOLOAD =~ /::DESTROY$/;
+ my $func = $AUTOLOAD;
+ # print "autoloading $func\n";
+ $func =~ s/^.*:://;
+ my $tag;
+ carp "Undefined subroutine $func called"
+ if $func !~ /^add_(.*)$/ ||
+ !($tag = $Funcs{lc $1}) ||
+ !exists $Top_tag_order{$tag};
+ no strict "refs";
+ *$func = sub
+ {
+ my $self = shift;
+ my $r = $self->add_record(tag => $tag);
+ unless ($tag =~ /^(HEAD|TRLR)$/)
+ {
+ my $x = @_ ? shift : $tag eq "SUBM" ? "SUBM" : substr $tag, 0, 1;
+ carp "Invalid xref $x requested in $func"
+ unless $x =~ /^[[:alpha:]]+(\d*)$/;
+ $x = $self->next_xref($x) unless length $1;
+ $r->{xref} = $x;
+ $self->{xrefs}{$r->{xref}} = $r;
+ }
+ $r
+ };
+ goto &$func
+}
+
+use Gedcom::Grammar 1.10;
+use Gedcom::Individual 1.10;
+use Gedcom::Family 1.10;
+use Gedcom::Event 1.10;
sub new
{
@@ -176,6 +234,7 @@ sub new
xrefs => {},
@_
};
+
# TODO - find a way to do this nicely for different grammars
$self->{types}{INDI} = "Individual";
$self->{types}{FAM} = "Family";
@@ -190,8 +249,19 @@ sub new
my $grammar;
if (defined $self->{grammar_file})
{
+ my $version;
+ if (defined $self->{grammar_version})
+ {
+ $version = $self->{grammar_version};
+ }
+ else
+ {
+ ($version) = $self->{grammar_file} =~ /(\d+(\.\d+)*)/;
+ }
+ die "version must be a gedcom version number\n" unless $version;
return undef unless
$grammar = Gedcom::Grammar->new(file => $self->{grammar_file},
+ version => $version,
callback => $self->{callback});
}
else
@@ -210,22 +280,79 @@ sub new
@c = map { $_->{top} = $grammar; @{$_->{items}} } @c;
}
- # now read in the gedcom file
- if (defined $self->{gedcom_file})
+ # now read in or create the gedcom file
+ return undef unless
+ my $r = $self->{record} = Gedcom::Record->new
+ (
+ defined $self->{gedcom_file} ? (file => $self->{gedcom_file}) : (),
+ line => 0,
+ tag => "GEDCOM",
+ grammar => $grammar->structure("GEDCOM"),
+ gedcom => $self,
+ callback => $self->{callback}
+ );
+
+ unless (defined $self->{gedcom_file})
{
- return undef unless
- $self->{record} =
- Gedcom::Record->new(file => $self->{gedcom_file},
- line => 0,
- tag => "GEDCOM",
- grammar => $grammar->structure("GEDCOM"),
- gedcom => $self,
- callback => $self->{callback});
- $self->{record}{items} = [ Gedcom::Record->new(tag => "TRLR") ]
- unless @{$self->{record}{items}};
- $self->collect_xrefs;
+
+ # Add the required elements, unless they are already there.
+
+ unless ($r->get_record("head"))
+ {
+ my $me = "Unknown user";
+ my $login = $me;
+ if ($login = getlogin || (getpwuid($<))[0] || $ENV{USER} || $ENV{LOGIN})
+ {
+ my $name;
+ eval { $name = (getpwnam($login))[6] };
+ $me = $name || $login;
+ }
+ my $date = localtime;
+
+ my ($l0, $l1, $l2, $l3);
+ $l0 = $self->add_header;
+ $l1 = $l0->add("SOUR", "Gedcom.pm");
+ $l1->add("NAME", "Gedcom.pm");
+ $l1->add("VERS", $VERSION);
+ $l2 = $l1->add("CORP", "Paul Johnson");
+ $l2->add("ADDR", "http://www.pjcj.net");
+ $l2 = $l1->add("DATA");
+ $l3 = $l2->add("COPR",
+ 'Copyright 1998-2002, Paul Johnson (pjcj@cpan.org)');
+ $l1 = $l0->add("NOTE", "");
+ for (split /\n/, <<'EOH')
+This output was generated by Gedcom.pm.
+Gedcom.pm is Copyright 1999-2002, Paul Johnson (pjcj@cpan.org)
+Version 1.10 - 5th March 2002
+
+Gedcom.pm is free. It is licensed under the same terms as Perl itself.
+
+The latest version of Gedcom.pm should be available from my homepage:
+http://www.pjcj.net
+EOH
+ {
+ $l1->add("CONT", $_);
+ };
+ $l1 = $l0->add("GEDC");
+ $l1->add("VERS", $self->{grammar}{version});
+ $l1->add("FORM", "LINEAGE-LINKED");
+ $l0->add("DATE", $date);
+ $l0->add("CHAR", "ANSEL");
+ my $s = $r->get_record("subm");
+ unless ($s)
+ {
+ $s = $self->add_submitter;
+ $s->add("NAME", $me);
+ }
+ $l0->add("SUBM", $s->xref);
+ }
+
+ $self->add_trailer unless $r->get_record("trlr");
}
- $self;
+
+ $self->collect_xrefs;
+
+ $self
}
sub write
@@ -247,8 +374,8 @@ sub write_xml
<!--
This output was generated by Gedcom.pm.
-Gedcom.pm is Copyright 1999-2001, Paul Johnson (pjcj@cpan.org)
-Version 1.09 - 12th February 2001
+Gedcom.pm is Copyright 1999-2002, Paul Johnson (pjcj@cpan.org)
+Version 1.10 - 5th March 2002
Gedcom.pm is free. It is licensed under the same terms as Perl itself.
@@ -261,11 +388,17 @@ EOH
$self->{fh}->close or die "Can't close $file: $!";
}
+sub add_record
+{
+ my $self = shift;
+ $self->{record}->add_record(@_);
+}
+
sub collect_xrefs
{
my $self = shift;
my ($callback) = @_;
- $self->{gedcom}{xrefs} = [];
+ $self->{xrefs} = {};
$self->{record}->collect_xrefs($callback);
}
@@ -275,7 +408,7 @@ sub resolve_xref
my ($x) = @_;
my $xref;
$xref = $self->{xrefs}{$x =~ /^\@(.+)\@$/ ? $1 : $x} if defined $x;
- $xref;
+ $xref
}
sub resolve_xrefs
@@ -302,7 +435,7 @@ sub validate
{
$ok = 0 unless $item->validate_semantics;
}
- $ok;
+ $ok
}
sub normalise_dates
@@ -345,23 +478,11 @@ sub sort_sub
# subroutine to sort on tag order first, and then on xref
- my $tag_order =
- {
- HEAD => 1,
- SUBM => 2,
- INDI => 3,
- FAM => 4,
- NOTE => 5,
- REPO => 6,
- SOUR => 7,
- TRLR => 8,
- };
-
my $t = sub
{
my ($r) = @_;
return -2 unless defined $r->{tag};
- exists $tag_order->{$r->{tag}} ? $tag_order->{$r->{tag}} : -1
+ exists $Top_tag_order{$r->{tag}} ? $Top_tag_order{$r->{tag}} : -1
};
my $x = sub
@@ -384,8 +505,7 @@ sub order
{
my $self = shift;
my $sort_sub = shift || sort_sub; # use default sort unless one is passed in
- local *_ss = $sort_sub;
- @{$self->{record}{items}} = sort _ss @{$self->{record}->_items}
+ @{$self->{record}{items}} = sort $sort_sub @{$self->{record}->_items}
}
sub individuals
@@ -404,9 +524,15 @@ sub get_individual
{
my $self = shift;
my $name = "@_";
+ my $all = wantarray;
+ my @i;
my $i = $self->resolve_xref($name) || $self->resolve_xref(uc $name);
- return $i if $i;
+ if ($i)
+ {
+ return $i unless $all;
+ push @i, $i;
+ }
# search for the name in the specified order
my $ordered = sub
@@ -437,7 +563,6 @@ sub get_individual
# look for various matches in decreasing order of exactitude
my @individuals = $self->individuals;
- my @i;
# Store the name with the individual to avoid continually recalculating it.
# This is a bit like a Schwartzian transform, with a grep instead of a sort.
@@ -447,7 +572,8 @@ sub get_individual
for my $n ( map { qr/^$_$/, qr/\b$_\b/, $_ } map { $_, qr/$_/i } qr/\Q$name/ )
{
- return wantarray ? @i : $i[0] if @i = $ordered->($n, @ind)
+ push @i, $ordered->($n, @ind);
+ return $i[0] if !$all && @i;
}
# create an array with one element per name
@@ -456,18 +582,34 @@ sub get_individual
split / /, $name;
for my $t (0 .. $#{$names[0]})
{
- return wantarray ? @i : $i[0] if @i = $unordered->(\@names, $t, @ind)
+ push @i, $unordered->(\@names, $t, @ind);
+ return $i[0] if !$all && @i;
}
# check soundex
- my @sdx = map { [ $_->soundex => $_ ] } @individuals;
+ my @sdx = map { my $s = $_->soundex; $s ? [ $s => $_ ] : () } @individuals;
+
+ my $soundex = soundex($name);
+ for my $n ( map { qr/$_/ } $name, ($soundex || ()) )
+ {
+ push @i, $ordered->($n, @sdx);
+ return $i[0] if !$all && @i;
+ }
+
+ return undef unless $all;
- for my $n ( map { qr/$_/ } $name, soundex($name) )
+ my @s;
+ my %s;
+ for (@i)
{
- return wantarray ? @i : $i[0] if @i = $ordered->($n, @sdx)
+ unless (exists $s{$_->{xref}})
+ {
+ push @s, $_;
+ $s{$_->{xref}}++;
+ }
}
- return wantarray ? () : undef;
+ @s
}
sub next_xref
@@ -492,12 +634,13 @@ __END__
Gedcom - a module to manipulate Gedcom genealogy files
-Version 1.09 - 12th February 2001
+Version 1.10 - 5th March 2002
=head1 SYNOPSIS
use Gedcom;
+ my $ged = Gedcom->new;
my $ged = Gedcom->new(gedcom_file => $gedcom_file);
my $ged = Gedcom->new(grammar_version => 5.5,
gedcom_file => $gedcom_file,
@@ -514,15 +657,17 @@ Version 1.09 - 12th February 2001
my %xrefs = $ged->renumber;
$ged->order;
$ged->write($new_gedcom_file, $flush);
- $ged->write_xml($fh, $level);
+ $ged->write_xml($new_xml_file);
my @individuals = $ged->individuals;
my @families = $ged->families;
my $me = $ged->get_individual("Paul Johnson");
my $xref = $ged->next_xref("I");
+ my $record = $ged->add_header;
+
=head1 DESCRIPTION
-Copyright 1998-2001, Paul Johnson (pjcj@cpan.org)
+Copyright 1998-2002, Paul Johnson (pjcj@cpan.org)
This software is free. It is licensed under the same terms as Perl itself.
@@ -539,10 +684,12 @@ description. Part of the reason I wrote this module is because I don't
do that. Well, I didn't. I can now although I prefer not to...
Requirements:
+
Perl 5.005 or later
ActivePerl5 Build Number 520 or later has been reported to work
Optional Modules:
+
Date::Manip.pm to work with dates
Text::Soundex.pm to use soundex
Parse::RecDescent.pm to use lines2perl
@@ -567,20 +714,20 @@ file, such as reformatting dates, renumbering entries and ordering the
entries. It also allows access to individuals, and then to relations of
individuals, for example sons, siblings, spouse, parents and so forth.
-This release includes a lines2perl program to convert LifeLines programs
-to Perl. The program works, but it has a few rough edges, and some
-missing functionality. I'll be working on it when it hits the top of my
-TODO list.
+The distribution includes a lines2perl program to convert LifeLines
+programs to Perl. The program works, but it has a few rough edges, and
+some missing functionality. I'll be working on it when it hits the top
+of my TODO list.
-This release provides an option for read only access to the gedcom file.
+There is now an option for read only access to the gedcom file.
Actually, this doesn't stop you changing or writing the file, but it
does parse the gedcom file lazily, meaning that only those portions of
the gedcom file which are needed will be read. This can provide a
substantial saving of time and memory providing that not too much of the
gedcom file is read. If you are going to read the whole gedcom file,
-this mode is less efficient.
+this mode is less efficient unless you do some manual housekeeping.
-Note that this is an early release of this software - caveat emptor.
+Note that this is still considered beta software - caveat emptor.
Should you find this software useful, or if you make changes to it, or
if you would like me to make changes to it, please send me mail. I
@@ -590,10 +737,11 @@ decisions when I feel the need to make changes to the interface.
There is a low volume mailing list available for discussing the use of
Perl in conjunction with genealogical work. This is an appropriate
-forum for discussing Gedcom.pm. To subscribe to the regular list, send
-a message to majordomo@icomm.ca and put subscribe S<perl-gedcom> as the
-body of the message. To get on the digest version of the list, put
-subscribe S<perl-gedcom-digest>.
+forum for discussing Gedcom.pm and if you use or are interested in this
+module I would encourage you to join the list. To subscribe to the
+regular list, send a message to majordomo@icomm.ca and put subscribe
+S<perl-gedcom> as the body of the message. To get on the digest version
+of the list, put subscribe S<perl-gedcom-digest>.
To store my genealogy I wrote a syntax file (gedcom.vim) and used vim
(http://www.vim.org) to enter the data, and Gedcom.pm to validate and
@@ -659,8 +807,8 @@ record within an individual.
my $d = $b->date;
Be aware that if you access a record in scalar context, but there is no
-such record, then undef is returned. In this case, $b would be undef if
-$i had no birth record. This is another reason why looping through
+such record, then undef is returned. In this case, $d would be undef if
+$b had no date record. This is another reason why looping through
records is a nice solution, all else being equal.
Access to values can also be gained through the get_value() function.
@@ -735,6 +883,8 @@ See Gedcom::Record.pm for more details.
=head2 new
+ my $ged = Gedcom->new;
+
my $ged = Gedcom->new(gedcom_file => $gedcom_file);
my $ged = Gedcom->new(grammar_version => 5.5,
@@ -747,7 +897,9 @@ See Gedcom::Record.pm for more details.
Create a new gedcom object.
-gedcom_file is the name of the gedcom file to parse.
+gedcom_file is the name of the gedcom file to parse. If you do not
+supply a gedcom_file parameter then you will get an empty Gedcom object,
+empty that is apart from a few mandatory records.
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
@@ -777,7 +929,8 @@ data will generally mean that the data will be written which means that
the data will first be read, the read_only option is generally useful
when the data will not be written and when not all the data will be
read. You may find it useful to experiment with this option and check
-the amount of CPU time and memory that your application uses.
+the amount of CPU time and memory that your application uses. You may
+also need to read this paragraph a few times to understand it. Sorry.
callback is an optional reference to a subroutine which will be called
at various times while the gedcom file (and the grammar file, if
@@ -806,9 +959,9 @@ but the new file name must be specified.
=head2 write_xml
- $ged->write_xml($fh);
+ $ged->write_xml($new_xml_file);
-Write the item to a FileHandle as XML.
+Write the gedcom file as XML.
Takes the name of the new gedcom file.
@@ -867,8 +1020,8 @@ Returns true iff the gedcom object is valid.
$ged->normalise_dates;
$ged->normalise_dates("%A, %E %B %Y");
-Change all recognised dates into a consistent format. This routine used
-Date::Manip to do the work, so you can look at it's documentation
+Change all recognised dates into a consistent format. This routine uses
+Date::Manip to do the work, so you can look at its documentation
regarding formats that are recognised and % sequences for the output.
Optionally takes a format to use for the output. The default is
@@ -888,7 +1041,7 @@ Optional parameters are:
xrefs => list of xrefs to renumber first
As a record is renumbered, it is assigned the next available number.
-The husband, wife, children parents and siblings are then renumbered in
+The husband, wife, children, parents and siblings are then renumbered in
that order. This helps to ensure that families are numerically close
together.
@@ -933,8 +1086,10 @@ Return a list of all the families.
Return a list of all individuals matching the specified name.
-There are thirteen matches performed, and the results from the first
-successful match are returned.
+There are thirteen matches performed, in decreasing order of exactitude.
+This means that the more likely matches are at the head of the list.
+
+In scalar context return the first match found.
The matches are:
View
11 Gedcom/CGI.pm
@@ -1,4 +1,4 @@
-# Copyright 2001, Paul Johnson (pjcj@cpan.org)
+# Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
# This software is free. It is licensed under the same terms as Perl itself.
@@ -15,10 +15,10 @@ package Gedcom::CGI;
use CGI qw(:cgi :html);
-use Gedcom 1.09;
+use Gedcom 1.10;
use vars qw($VERSION);
-$VERSION = "1.09";
+$VERSION = "1.10";
sub gedcom
{
@@ -105,6 +105,9 @@ sub indi
th([ "Event", "Date", "Place"]),
event_row("Birth", $i->birth),
event_row("Christening", $i->christening),
+ event_row("Baptism", $i->baptism),
+ event_row("Baptism", $i->bapl),
+ event_row("Endowment", $i->endowment),
event_row("Death", $i->death),
event_row("Burial", $i->burial),
event_row("Marriage", $i->get_record(qw(fams marriage))),
@@ -139,7 +142,7 @@ __END__
Gedcom::CGI - Basic CGI routines for Gedcom.pm
-Version 1.09 - 12th February 2001
+Version 1.10 - 5th March 2002
=head1 SYNOPSIS
View
8 Gedcom/Event.pm
@@ -1,4 +1,4 @@
-# Copyright 1999-2001, Paul Johnson (pjcj@cpan.org)
+# Copyright 1999-2002, Paul Johnson (pjcj@cpan.org)
# This software is free. It is licensed under the same terms as Perl itself.
@@ -13,10 +13,10 @@ require 5.005;
package Gedcom::Event;
-use Gedcom::Record 1.09;
+use Gedcom::Record 1.10;
use vars qw($VERSION @ISA);
-$VERSION = "1.09";
+$VERSION = "1.10";
@ISA = qw( Gedcom::Record );
# sub type
@@ -45,7 +45,7 @@ __END__
Gedcom::Event - a module to manipulate Gedcom events
-Version 1.09 - 12th February 2001
+Version 1.10 - 5th March 2002
=head1 SYNOPSIS
View
50 Gedcom/Family.pm
@@ -1,4 +1,4 @@
-# Copyright 1998-2001, Paul Johnson (pjcj@cpan.org)
+# Copyright 1998-2002, Paul Johnson (pjcj@cpan.org)
# This software is free. It is licensed under the same terms as Perl itself.
@@ -13,10 +13,10 @@ require 5.005;
package Gedcom::Family;
-use Gedcom::Record 1.09;
+use Gedcom::Record 1.10;
use vars qw($VERSION @ISA);
-$VERSION = "1.09";
+$VERSION = "1.10";
@ISA = qw( Gedcom::Record );
sub husband
@@ -67,6 +67,36 @@ sub girls
wantarray ? @a : $a[0]
}
+sub add_husband
+{
+ my $self = shift;
+ my ($husband) = @_;
+ $husband = $self->{gedcom}->get_individual($husband)
+ unless UNIVERSAL::isa($husband, "Gedcom::Individual");
+ $self->add("husband", $husband);
+ $husband->add("fams", $self->{xref});
+}
+
+sub add_wife
+{
+ my $self = shift;
+ my ($wife) = @_;
+ $wife = $self->{gedcom}->get_individual($wife)
+ unless UNIVERSAL::isa($wife, "Gedcom::Individual");
+ $self->add("wife", $wife);
+ $wife->add("fams", $self->{xref});
+}
+
+sub add_child
+{
+ my $self = shift;
+ my ($child) = @_;
+ $child = $self->{gedcom}->get_individual($child)
+ unless UNIVERSAL::isa($child, "Gedcom::Individual");
+ $self->add("child", $child);
+ $child->add("famc", $self->{xref});
+}
+
sub print
{
my $self = shift;
@@ -82,7 +112,7 @@ __END__
Gedcom::Family - a module to manipulate Gedcom families
-Version 1.09 - 12th February 2001
+Version 1.10 - 5th March 2002
=head1 SYNOPSIS
@@ -131,4 +161,16 @@ returns a list of individuals holding that releation in $f.
Return the number of children in the family, as specified or from
counting.
+=head2 Add functions
+
+ $f->add_husband($i);
+ $f->add_wife($i);
+ $f->add_child($i);
+
+Add the specified individual to the family in the appropriate position.
+
+These functions also take care of the references from the individual
+back to the family, and are to be prefered to the low level addition
+functions which do not do this.
+
=cut
View
64 Gedcom/Grammar.pm
@@ -1,4 +1,4 @@
-# Copyright 1998-2001, Paul Johnson (pjcj@cpan.org)
+# Copyright 1998-2002, Paul Johnson (pjcj@cpan.org)
# This software is free. It is licensed under the same terms as Perl itself.
@@ -15,10 +15,10 @@ package Gedcom::Grammar;
use Data::Dumper;
-use Gedcom::Item 1.09;
+use Gedcom::Item 1.10;
use vars qw($VERSION @ISA);
-$VERSION = "1.09";
+$VERSION = "1.10";
@ISA = qw( Gedcom::Item );
sub structure
@@ -31,16 +31,17 @@ sub structure
{ map { $_->{structure} ? ($_->{structure} => $_) : () }
@{$self->{top}{items}} };
}
+ # print Dumper $self->{top}{structures};
$self->{top}{structures}{$struct}
}
sub item
{
my $self = shift;
my ($tag) = @_;
- return undef unless defined $tag;
+ return unless defined $tag;
my $valid_items = $self->valid_items;
- exists $valid_items->{$tag} ? $valid_items->{$tag}{grammar} : undef
+ map { $_->{grammar} } @{$valid_items->{$tag}}
}
sub min
@@ -71,7 +72,7 @@ sub _valid_items
my $max = $item->max;
if ($item->{tag})
{
- $valid_items{$item->{tag}} =
+ push @{$valid_items{$item->{tag}}},
{
grammar => $item,
min => $min,
@@ -87,34 +88,38 @@ sub _valid_items
$item->{structure} = $structure;
while (my($tag, $g) = each %{$structure->valid_items})
{
- $valid_items{$tag} =
- {
- grammar => $g->{grammar},
- # min and max can be calculated by multiplication because
- # the grammar always permits multiple selection records, and
- # selection records never have compulsory records. This may
- # change in future grammars, but I would not expect it to -
- # such a grammar would seem to have little practical use.
- min => $g->{min} * $min,
- max => $g->{max} * $max
- };
+ push @{$valid_items{$tag}},
+ map {
+ grammar => $_->{grammar},
+ # min and max can be calculated by multiplication because
+ # the grammar always permits multiple selection records, and
+ # selection records never have compulsory records. This may
+ # change in future grammars, but I would not expect it to -
+ # such a grammar would seem to have little practical use.
+ min => $_->{min} * $min,
+ max => $_->{max} * $max
+ }, @$g;
}
if (exists $item->{items} && @{$item->{items}})
{
my $extra_items = $item->_valid_items;
- while (my ($sub_item, $sub_grammar) = each %valid_items)
+ while (my ($sub_item, $sub_grammars) = each %valid_items)
{
- $sub_grammar->{grammar}->valid_items;
- while (my ($i, $g) = each %$extra_items)
+ for my $sub_grammar (@$sub_grammars)
{
- # print "adding $i to $sub_item\n";
- $sub_grammar->{grammar}{_valid_items}{$i} = $g;
+ $sub_grammar->{grammar}->valid_items;
+ while (my ($i, $g) = each %$extra_items)
+ {
+ # print "adding $i to $sub_item\n";
+ $sub_grammar->{grammar}{_valid_items}{$i} = $g;
+ }
}
# print "giving @{[keys %{$sub_grammar->{grammar}->valid_items}]}\n";
}
}
}
}
+ # print "valid items are @{[keys %valid_items]}\n";
\%valid_items
}
@@ -132,14 +137,14 @@ __END__
Gedcom::Grammar - a module to manipulate Gedcom grammars
-Version 1.09 - 12th February 2001
+Version 1.10 - 5th March 2002
=head1 SYNOPSIS
use Gedcom::Grammar;
my $st = $grammar->structure("GEDCOM");
- my $sgr = $grammar->item("DATE");
+ my @sgr = $grammar->item("DATE");
my @items = $grammar->valid_items;
my $min = $grammar->min;
my $max = $grammar->max;
@@ -174,9 +179,10 @@ Return the grammar item of the specified structure, if it exists, or undef.
=head2 item
- my $sgr = $grammar->item("DATE");
+ my @sgr = $grammar->item("DATE");
-Return the grammar item of the specified sub-item, if it exists, or undef.
+Return a list of the possible grammar items of the specified sub-item,
+if it exists.
=head2 min
@@ -200,9 +206,9 @@ Return a list of tags of the grammar's sub-items
my @items = $grammar->valid_items;
-Return a hash detailing all the valid sub-items of the grammar item. The
-key is the tag of the sub-item and the value is another hash with three
-members:
+Return a hash detailing all the valid sub-items of the grammar item.
+The key is the tag of the sub-item and the value is an array of hashes
+with three members:
grammar => the sub-item grammar
min => the minimum permissible number of these sub-items
View
3,597 Gedcom/Grammar_5_5.pm
2,348 additions, 1,249 deletions not shown because the diff is too large. Please use a local Git client to view these changes.
View
30 Gedcom/Individual.pm
@@ -1,4 +1,4 @@
-# Copyright 1998-2001, Paul Johnson (pjcj@cpan.org)
+# Copyright 1998-2002, Paul Johnson (pjcj@cpan.org)
# This software is free. It is licensed under the same terms as Perl itself.
@@ -13,10 +13,10 @@ require 5.005;
package Gedcom::Individual;
-use Gedcom::Record 1.09;
+use Gedcom::Record 1.10;
use vars qw($VERSION @ISA);
-$VERSION = "1.09";
+$VERSION = "1.10";
@ISA = qw( Gedcom::Record );
sub name
@@ -50,7 +50,10 @@ sub given_names
{
my $self = shift;
my $name = $self->name;
- $name =~ s|/([^/]*)/?||;
+ $name =~ s|/([^/]*)/?| |;
+ $name =~ s|^\s+||;
+ $name =~ s|\s+$||;
+ $name =~ s|\s+| |g;
$name
}
@@ -230,13 +233,13 @@ sub delete
unless $fam->tag_value("HUSB") ||
$fam->tag_value("WIFE") ||
$fam->tag_value("CHIL");
- # TODO - write Family::delete
+ # TODO - write Family::delete ?
# - delete associated notes?
}
}
$ret = 0 unless $self->{gedcom}{record}->delete_record($self);
- delete $self->{gedcom}{xrefs}{$xref};
- $ret;
+ $_[0] = undef if $ret; # Can't reuse a deleted person
+ $ret
}
sub print
@@ -257,10 +260,14 @@ sub print_generations
return unless $generations > 0;
my $i = " " x $indent;
print "$i$self->{xref} (", $self->rin, ") ", $self->name, "\n" unless $indent;
+ $self->print;
for my $fam ($self->fams)
{
- for my $spouse ($fam->husband, $fam->wife)
+ # $fam->print;
+ for my $spouse ($fam->parents)
{
+ next unless $spouse;
+ # print "[$spouse]\n";
next if $self->xref eq $spouse->xref;
print "$i= $spouse->{xref} (", $spouse->rin, ") ", $spouse->name, "\n";
}
@@ -294,7 +301,7 @@ __END__
Gedcom::Individual - a module to manipulate Gedcom individuals
-Version 1.09 - 12th February 2001
+Version 1.10 - 5th March 2002
=head1 SYNOPSIS
@@ -355,7 +362,7 @@ Return the surname of the individual.
my $given_names = $i->given_names;
-Return the given names of the individual.
+Return the given names of the individual, with spaces normalised.
=head2 soundex
@@ -405,6 +412,9 @@ eg:
Delete $i from the data structure.
+This function will also set $i to undef. This is to remind you that the
+individual cannot be used again.
+
Returns true iff $i was successfully deleted.
=head2 Family functions
View
145 Gedcom/Item.pm
@@ -1,4 +1,4 @@
-# Copyright 1998-2001, Paul Johnson (pjcj@cpan.org)
+# Copyright 1998-2002, Paul Johnson (pjcj@cpan.org)
# This software is free. It is licensed under the same terms as Perl itself.
@@ -16,23 +16,30 @@ package Gedcom::Item;
use Symbol;
use vars qw($VERSION);
-$VERSION = "1.09";
+$VERSION = "1.10";
sub new
{
my $proto = shift;
my $class = ref($proto) || $proto;
- my $self = { @_ };
+ my $self =
+ {
+ level => -3,
+ file => "*",
+ line => 0,
+ items => [],
+ @_
+ };
bless $self, $class;
- $self->read if $self->{file};
+ $self->read if $self->{file} && $self->{file} ne "*";
$self;
}
sub copy
{
my $self = shift;
my $item = $self->new;
- for my $key (qw(level xref tag value min max gedcom))
+ for my $key (qw(level xref tag value pointer min max gedcom))
{
$item->{$key} = $self->{$key} if exists $self->{$key}
}
@@ -46,12 +53,12 @@ sub read
# $self->{fh} = FileHandle->new($self->{file})
$self->{fh} = gensym;
- open($self->{fh}, $self->{file}) or die "Can't open file $self->{file}: $!";
+ open $self->{fh}, $self->{file} or die "Can't open file $self->{file}: $!";
binmode $self->{fh};
# find out how big the file is
seek($self->{fh}, 0, 2);
- my $size = tell;
+ my $size = tell $self->{fh};
seek($self->{fh}, 0, 0);
# initial callback
@@ -61,7 +68,7 @@ sub read
my $count = 0;
return undef
if $callback &&
- !$callback->($title, $txt1, "Record $count", tell, $size);
+ !$callback->($title, $txt1, "Record $count", tell $self->{fh}, $size);
$self->level($self->{grammar} ? -1 : -2);
@@ -99,7 +106,7 @@ sub read
# print Dumper $self;
}
- unless ($self->{items})
+ unless (@{$self->{items}})
{
# use Data::Dumper;
# print Dumper $self->{items};
@@ -113,9 +120,11 @@ sub read
if ($self->{grammar})
{
my $tag = $item->{tag};
- if (my $g = $self->{grammar}->item($tag))
+ my @g = $self->{grammar}->item($tag);
+ # print "<$tag> => <@g>\n";
+ if (@g)
{
- $self->parse($item, $g);
+ $self->parse($item, $g[0]);
push @{$self->{items}}, $item;
$count++;
}
@@ -135,7 +144,7 @@ sub read
if ref $item &&
$callback &&
!$callback->($title, $txt1, "Record $count line " . $item->{line},
- tell, $size);
+ tell $self->{fh}, $size);
}
}
@@ -227,7 +236,7 @@ sub skip_items
my $self = shift;
my ($item) = @_;
my $level = $item->{level};
- my $cpos = $item->{cpos} = tell;
+ my $cpos = $item->{cpos} = tell $self->{fh};
# print "skipping items to level $level at $item->{line}:$cpos\n";
my $fh = $self->{fh};
while (my $l = <$fh>)
@@ -244,16 +253,17 @@ sub skip_items
last;
}
}
- $cpos = tell;
+ $cpos = tell $self->{fh};
}
}
sub next_item
{
- my $self = shift;
+ my $self = shift;
my ($item) = @_;
- my $bpos = tell;
- # print "At $bpos\n";
+ my $bpos = tell $self->{fh};
+ my $bline = $.;
+ # print "At $bpos:$bline\n";
my $rec;
my $fh = $self->{fh};
if ($rec = $self->{stored_item})
@@ -263,8 +273,8 @@ sub next_item
elsif ((!$rec || !$rec->{level}) && (my $line = $self->next_text_line))
{
# TODO - tidy this up
- # print "line is <$line>";
my $line_number = $.;
+ # print "line $line_number is <$line>";
if (my ($structure) = $line =~ /^\s*(\w+): =\s*$/)
{
$rec = $self->new(level => -1,
@@ -337,7 +347,7 @@ sub next_item
$rec->{xref} = $xref =~ /^\@(.+)\@$/ ? $1 : $xref
if defined $xref;
$rec->{tag} = $tag if defined $tag;
- $rec->{value} = $value =~ /^\@(.+)\@$/ ? $1 : $value
+ $rec->{value} = ($rec->{pointer} = $value =~ /^\@(.+)\@$/) ? $1 : $value
if defined $value;
$rec->{min} = $min if defined $min;
$rec->{max} = $max if defined $max;
@@ -346,12 +356,14 @@ sub next_item
{
# print " -- pushing back\n";
seek($fh, $bpos, 0);
- $.--;
+ # print "$.\n";
+ $. = $bline;
+ # print "$.\n";
}
}
elsif ($line =~ /^\s*[\[\|\]]\s*(?:\/\*.*\*\/\s*)?$/)
{
- # The grammar requires a single selection from its items
+ # The grammar requires a single selection from its items.
return "selection";
}
else
@@ -387,6 +399,7 @@ sub next_text_line
my $line = "";
# $line = $self->next_line until !defined $line || $line =~ /\S/;
my $fh = $self->{fh};
+ # print "-- $.\n";
$line = <$fh> until !defined $line || $line =~ /\S/;
$line;
}
@@ -397,13 +410,15 @@ sub write
my ($fh, $level, $flush) = @_;
my @p;
push(@p, $level . " " x $level) unless $flush || $level < 0;
- push(@p, "\@$self->{xref}\@") if $self->{xref};
- push(@p, $self->{tag}) if $level >= 0 && $self->{tag};
+ push(@p, "\@$self->{xref}\@") if defined $self->{xref} &&
+ length $self->{xref};
+ push(@p, $self->{tag}) if $level >= 0;
push(@p, ref $self->{value}
? "\@$self->{value}{xref}\@"
: $self->resolve_xref($self->{value})
? "\@$self->{value}\@"
- : $self->{value}) if $self->{value};
+ : $self->{value}) if defined $self->{value} &&
+ length $self->{value};
$fh->print("@p");
$fh->print("\n") unless $level < 0;
for my $c (0 .. @{$self->_items} - 1)
@@ -508,24 +523,60 @@ sub get_children
$self->get_item(@_)
}
+sub parent
+{
+ my $self = shift;
+
+ my $i = "$self";
+ my @records = ($self->{gedcom}{record});
+
+ while (@records)
+ {
+ my $r = shift @records;
+ for (@{$r->_items})
+ {
+ return $r if $i eq "$_";
+ push @records, $r;
+ }
+ }
+
+ undef
+}
+
+sub delete
+{
+ my $self = shift;
+
+ my $parent = $self->parent;
+
+ return unless $parent;
+
+ $parent->delete_item($self);
+}
+
sub delete_item
{
my $self = shift;
my ($item) = @_;
+
my $i = "$item";
my $n = 0;
for (@{$self->_items})
{
- my $it = "$_";
- # print "matching $ch against $c\n";
- last if $i eq $it;
+ last if $i eq "$_";
$n++;
}
+
+ return 0 unless $n < @{$self->{items}};
+
# print "deleting item $n of $#{$self->{items}}\n";
splice @{$self->{items}}, $n, 1;
+ delete $self->{gedcom}{xrefs}{$item->{xref}} if defined $item->{xref};
+
+ 1
}
-for my $func (qw(level xref tag value min max gedcom file line))
+for my $func (qw(level xref tag value pointer min max gedcom file line))
{
no strict "refs";
*$func = sub
@@ -582,7 +633,7 @@ __END__
Gedcom::Item - a base class for Gedcom::Grammar and Gedcom::Record
-Version 1.09 - 12th February 2001
+Version 1.10 - 5th March 2002
=head1 SYNOPSIS
@@ -601,12 +652,15 @@ Version 1.09 - 12th February 2001
$item->print;
my $item = $item->get_item("CHIL", 2);
my @items = $item->get_item("CHIL");
+ my $parent = $item->parent;
+ my $success = $item->delete;
$item->delete_item($sub_item);
my $v = $item->level;
$item->level(1);
my $v = $item->xref;
my $v = $item->tag;
my $v = $item->value;
+ my $v = $item->pointer;
my $v = $item->min;
my $v = $item->max;
my $v = $item->gedcom;
@@ -641,6 +695,10 @@ The name of the tag.
The value of the item.
+=head2 $item->{pointer}
+
+True iff the value is a pointer to another item.
+
=head2 $item->{min}
The minimum number of items allowed.
@@ -791,19 +849,45 @@ NOTE - This function is deprecated - use get_item instead
my @children = get_children("CHIL");
+=head2 parent
+
+ my $parent = $item->parent;
+
+Returns the parent of the item or undef if there is none.
+
+Note that this is an expensive function. A child does not know who its
+parent is, and so this function searches through all items looking for
+one with the appropriate child.
+
+=head2 delete
+
+ my $success = $item->delete;
+
+Deletes the item.
+
+Note that this is an expensive function. It use parent() described
+above. It is better to use $parent->delete_item($child), assuming that
+you know $parent.
+
+Note too that this function calls delete_item(), so its caveats apply.
+
=head2 delete_item
$item->delete_item($sub_item);
Delete the specified sub-item from the item.
+Note that this function doesn't do any housekeeping. It is up to you to
+ensure that you don't leave any dangling pointers.
+
=head2 Access functions
my $v = $item->level;
$item->level(1);
my $v = $item->xref;
my $v = $item->tag;
my $v = $item->value;
+ my $v = $item->pointer;
my $v = $item->min;
my $v = $item->max;
my $v = $item->gedcom;
@@ -852,6 +936,7 @@ items.
Delete all the sub-items, allowing the memory to be reused. If the
sub-items are required again, they will be reread.
-It should not be necessary to use this function.
+It should not be necessary to use this function unless you are using
+read_only mode and need to reclaim your memory.
=cut
View
132 Gedcom/LifeLines.pm
@@ -1,4 +1,4 @@
-# Copyright 1999-2001, Paul Johnson (pjcj@cpan.org)
+# Copyright 1999-2002, Paul Johnson (pjcj@cpan.org)
# This software is free. It is licensed under the same terms as Perl itself.
@@ -20,10 +20,10 @@ BEGIN
eval "use Roman ()";
}
-use Gedcom 1.09;
+use Gedcom 1.10;
use vars qw($VERSION @ISA @EXPORT);
-$VERSION = "1.09";
+$VERSION = "1.10";
@ISA = qw( Exporter );
@EXPORT = qw
(
@@ -48,7 +48,7 @@ $VERSION = "1.09";
menuchoose
lower upper capitalize trim rjustify
save strsave concat strconcat strlen
- substring index substring
+ substring index
d card ord alpha roman
strsoundex
strtoint atoi
@@ -118,7 +118,9 @@ sub name
{
my ($indi, $cased) = @_;
return unless $indi;
- !defined $cased || $cased ? $indi->cased_name : $indi->name
+ my $name = !defined $cased || $cased ? $indi->cased_name : $indi->name;
+ $name =~ s|/||g;
+ $name
}
sub fullname
@@ -260,8 +262,8 @@ sub parents
{
my ($indi) = @_;
return unless $indi;
- my @a = $indi->famc;
- scalar @a
+ my $a = $indi->famc;
+ $a
}
sub title
@@ -450,7 +452,7 @@ sub parent
{
my ($record) = @_;
return unless $record;
- die "LifeLines parent function not yet implemented"
+ $record->parent
}
sub child
@@ -464,7 +466,21 @@ sub sibling
{
my ($record) = @_;
return unless $record;
- die "LifeLines sibling function not yet implemented"
+
+ my $parent = $record->parent;
+ return unless $parent;
+
+ my $r = "$record";
+ my $n = 0;
+ for (@{$parent->_items})
+ {
+ last if $r eq "$_";
+ $n++;
+ }
+
+ return unless $n < $#{$parent->{items}};
+
+ $parent->{items}[$n + 1]
}
sub savenode
@@ -512,14 +528,8 @@ sub short
sub gettoday
{
- my $today = localtime;
- $today =~ s/\d\d:\d\d:\d\d //;
- my $date = Gedcom::Record->new(gedcom => $Ged,
- tag => "DATE",
- value => $today);
- my $event = Gedcom::Record->new(gedcom => $Ged,
- items => [$date]);
- $event
+ my $event = Gedcom::Event->new(gedcom => $Ged);
+ $event->add("date", uc join " ", (localtime)[2, 1, 4])
}
sub dayformat
@@ -612,19 +622,15 @@ sub extractnames
$$count = $$surname = 0;
my $name = $record->tag eq "NAME" ? $record->full_value : $record->name;
return unless $name;
- $name =~ s|/\s+|/|;
- $name =~ s|(/.*?)/s+/|$1/|;
- $$names = [ split ' ', $name ];
- $$count = scalar @$$names;
- for ($$surname = $$count; $$surname--;)
- {
- if ($$names->[$$surname] =~ s|/||g)
- {
- $$surname++;
- return;
- }
- }
- $$surname = 0;
+
+ my ($before, $sn, $after) = split "/", $name;
+ my @bf = split " ", $before;
+ my @af = split " ", $after;
+ $$count = @bf + @af; $$count++ if $sn;
+ $$names = [@bf, $sn || (), @af];
+ $$surname = $sn ? @bf + 1 : 0;
+
+ # print "[$name] [", join("|", @$$names), "], $$count, $$surname, \n";
return
}
@@ -808,15 +814,15 @@ sub strlen
sub substring
{
my ($string, $start, $end) = @_;
- substr $string, $start - 1, $end - $start
+ substr $string, $start - 1, $end - $start + 1
}
sub index
{
my ($string, $substring, $occurrence) = @_;
my $pos = 0;
while ($occurrence-- && ($pos = index $string, $substring, $pos) >= 0) {}
- $pos
+ $pos + 1
}
sub d
@@ -828,13 +834,29 @@ sub d
sub card
{
my ($number) = @_;
- die "LifeLines card function not yet implemented"
+ my @cardinals = qw
+ (
+ zero one two three four five six seven eight nine ten eleven twelve
+ );
+
+ $number < 0 || $number > $#cardinals ? $number : $cardinals[$number]
}
sub ord
{
my ($number) = @_;
- die "LifeLines ord function not yet implemented"
+ my @ordinals = qw
+ (
+ zeroth first second third fourth fifth sixth
+ seventh eighth ninth tenth eleventh twelfth
+ );
+ my @suffixes = qw( th st nd rd th th th th th th );
+
+ return if $number < 0;
+ return $ordinals[$number] if $number < @ordinals;
+ my $n = $number % 100;
+ return $number . "th" if $n < 10 && $n < 14;
+ return $number . $suffixes[$number % 10];
}
sub alpha
@@ -927,7 +949,11 @@ sub col
sub row
{
my ($row) = @_;
- $Row = $row - 1 unless $Line_mode;
+ unless ($Line_mode)
+ {
+ $Row = $row - 1;
+ $Column = 0;
+ }
return
}
@@ -962,15 +988,25 @@ sub qt
'"'
}
-sub newfile
{
- my ($file, $append) = @_;
- die "LifeLines newfile function not yet implemented"
-}
+ my $Openfile;
-sub outfile
-{
- die "LifeLines outfile function not yet implemented"
+ sub newfile
+ {
+ my ($filename, $append) = @_;
+
+ flush();
+ my $mode = $append ? ">>" : ">";
+ open LLOUT, "$mode$filename" or die "Cannot open $filename\n";
+ select LLOUT;
+ $Openfile = $filename;
+ return;
+ }
+
+ sub outfile
+ {
+ $Openfile
+ }
}
sub copyfile
@@ -1008,9 +1044,8 @@ sub deletefromset
my $keep = ($count && !$all) || $_->[0] ne $indi;
$count++ unless $keep;
$keep
- }
- @$set;
- $set = \@new;
+ } @$set;
+ $_[0] = \@new;
return
}
@@ -1226,7 +1261,7 @@ __END__
Gedcom::LifeLines - functions for lines2perl
-Version 1.09 - 12th February 2001
+Version 1.10 - 5th March 2002
=head1 SYNOPSIS
@@ -1243,18 +1278,13 @@ lines2perl program. Anything in here that finds a more general use
should probably be abstracted away to one of the more standard modules.
Functions yet to be implemented include:
- parent()
sibling()
getindiset()
choosechild()
choosefam()
chooseindi()
choosesubset()
menuchoose()
- card()
- ord()
- newfile()
- outfile()
gengedcom()
createnode()
addnode()
View
290 Gedcom/Record.pm
@@ -1,4 +1,4 @@
-# Copyright 1998-2001, Paul Johnson (pjcj@cpan.org)
+# Copyright 1998-2002, Paul Johnson (pjcj@cpan.org)
# This software is free. It is licensed under the same terms as Perl itself.
@@ -16,54 +16,48 @@ package Gedcom::Record;
use Carp;
BEGIN { eval "use Date::Manip" } # We'll use this if it is available
-use Gedcom::Item 1.09;
+use Gedcom::Item 1.10;
use vars qw($VERSION @ISA $AUTOLOAD);
-$VERSION = "1.09";
+$VERSION = "1.10";
@ISA = qw( Gedcom::Item );
-my %Funcs;
BEGIN
{
- while (my($tag, $name) = each(%$Gedcom::Tags))
- {
- # print "looking at tag $tag <$name>\n";
- $Funcs{$tag} = $Funcs{lc $tag} = $tag;
- if ($name)
- {
- $name =~ s/ /_/g;
- $Funcs{lc $name} = $tag;
- }
- }
- # use Data::Dumper;
- # print "Funcs are ", Dumper(\%Funcs);
- use subs keys %Funcs;
+ use subs keys %Gedcom::Funcs;
*tag_record = \&Gedcom::Item::get_item;
*delete_record = \&Gedcom::Item::delete_item;
*get_record = \&record;
}
+sub DESTROY {}
+
sub AUTOLOAD
{
my ($self) = @_; # don't change @_ because of the goto
return if $AUTOLOAD =~ /::DESTROY$/;
my $func = $AUTOLOAD;
# print "autoloading $func\n";
$func =~ s/^.*:://;
- carp "Undefined subroutine $func called" unless $Funcs{lc $func};
+ carp "Undefined subroutine $func called" unless $Gedcom::Funcs{lc $func};
no strict "refs";
*$func = sub
{
my $self = shift;
my ($count) = @_;
+ my $v;
+ # print "[[ $func ]]\n";
if (wantarray)
{
- return map { $_ && $_->full_value || $_ } $self->record([$func, $count]);
+ return map
+ { $_ && do { $v = $_->full_value; defined $v && length $v ? $v : $_ } }
+ $self->record([$func, $count]);
}
else
{
- my $record = $self->record([$func, $count]);
- return $record && $record->full_value || $record;
+ my $r = $self->record([$func, $count]);
+ # print "{$r}\n";
+ return $r && do { $v = $r->full_value; defined $v && length $v ? $v : $r }
}
};
goto &$func
@@ -82,7 +76,7 @@ sub record
warn "Invalid record of type ", ref $func, " requested";
return undef;
}
- my $record = $Funcs{lc $func};
+ my $record = $Gedcom::Funcs{lc $func};
unless ($record)
{
warn $func
@@ -100,26 +94,13 @@ sub record
wantarray ? @records : $records[0]
}
-sub set_record
-{
- my $self = shift;
- my $new_record = pop;
- my $last_record = pop;
- my $r = $self->record(@_);
- unless ($r)
- {
- warn "no record found";
- return;
- }
- my ($record, $count) = parse_func($last_record);
-}
-
sub get_value
{
my $self = shift;
if (wantarray)
{
- return map { $_->full_value || () } $self->record(@_);
+ return map { my $v = $_->full_value; defined $v and length $v ? $v : () }
+ $self->record(@_);
}
else
{
@@ -133,7 +114,8 @@ sub tag_value
my $self = shift;
if (wantarray)
{
- return map { $_->full_value || () } $self->tag_record(@_);
+ return map { my $v = $_->full_value; defined $v and length $v ? $v : () }
+ $self->tag_record(@_);
}
else
{
@@ -142,13 +124,142 @@ sub tag_value
}
}
+sub add_record
+{
+ my $self = shift;
+ my (%args) = @_;
+
+ die "No tag specified" unless defined $args{tag};
+
+ my $record = Gedcom::Record->new
+ (
+ gedcom => $self->{gedcom},
+ callback => $self->{callback},
+ %args
+ );
+
+ if (!defined $self->{grammar})
+ {
+ warn "$self->{tag} has no grammar\n";
+ }
+ elsif (my @g = $self->{grammar}->item($args{tag}))
+ {
+ $self->parse($record, $g[0]);
+ }
+ else
+ {
+ warn "$args{tag} is not a sub-item of $self->{tag}\n";
+ }
+
+ push @{$self->{items}}, $record;
+
+ $record
+}
+
+sub add
+{
+ my $self = shift;
+ my $val;
+ $val = pop if @_ > 1 && ref $_[-1] ne "ARRAY";
+
+ my @funcs = map { ref() ? $_ : split } @_;
+ $funcs[-1] = [$funcs[-1], 0] unless ref $funcs[-1];
+ my $r = $self->get_and_create(@funcs);
+
+ if (defined $val)
+ {
+ if (UNIVERSAL::isa($val, "Gedcom::Record"))
+ {
+ $r->{value} = $val->{xref};
+ $self->{gedcom}{xrefs}{$val->{xref}} = $val;
+ }
+ else
+ {
+ $r->{value} = $val;
+ }
+ }
+
+ $r
+}
+
+sub set
+{
+ my $self = shift;
+ my $val = pop;
+
+ my @funcs = map { ref() ? $_ : split } @_;
+ my $r = $self->get_and_create(@funcs);
+
+ if (UNIVERSAL::isa($val, "Gedcom::Record"))
+ {
+ $r->{value} = $val->{xref};
+ $self->{gedcom}{xrefs}{$val->{xref}} = $val;
+ }
+ else
+ {
+ $r->{value} = $val;
+ }
+
+ $r
+}
+
+sub get_and_create
+{
+ my $self = shift;
+ my @funcs = @_;
+
+ my $rec = $self;
+ for my $f (0 .. $#funcs)
+ {
+ my ($func, $count) = ($funcs[$f], 1);
+ ($func, $count) = @$func if ref $func eq "ARRAY";
+ $count--;
+
+ if (ref $func)
+ {
+ warn "Invalid record of type ", ref $func, " requested";
+ return undef;
+ }
+
+ my $record = $Gedcom::Funcs{lc $func};
+ unless ($record)
+ {
+ warn $func
+ ? "Non standard record of type $func requested"
+ : "Record type not specified";
+ $record = $func;
+ }
+
+ # print "$func [$count]\n";
+
+ my @records = $rec->tag_record($record);
+
+ if ($count < 0)
+ {
+ $rec = $rec->add_record(tag => $record);
+ }
+ elsif ($#records < $count)
+ {
+ my $new;
+ $new = $rec->add_record(tag => $record) for (0 .. @records - $count);
+ $rec = $new;
+ }
+ else
+ {
+ $rec = $records[$count];
+ }
+ }
+
+ $rec
+}
+
sub parse
{
-# print "parsing\n";
+ # print "parsing\n";
my $self = shift;
my ($record, $grammar) = @_;
-# print "checking "; $self->print();
-# print "against "; $grammar->print();
+ # print "checking "; $record->print();
+ # print "against "; $grammar->print();
my $t = $record->{tag};
my $g = $grammar->{tag};
die "Can't match $t with $g" if $t && $t ne $g; # internal error
@@ -158,27 +269,53 @@ sub parse
for my $r (@{$record->{items}})
{
my $tag = $r->{tag};
- if (my $i = $grammar->item($tag))
+ my @i;
+ for my $i ($grammar->item($tag))
{
- $self->parse($r, $i);
+ # Try to get rid of matches we don't want because they only match
+ # in name.
+
+ # Check that the level is appropriate.
+ # print " - ", $i->level, "|", $r->level, "\n";
+ next unless $i->level =~ /^[+0]/ || $i->level == $r->level;
+
+ # Check we have a pointer iff we need one.
+ # print " + ", $i->value, "|", $r->value, "\n";
+ next if $i->value && $r->value && ($i->value =~ /^<XREF:/ ^ $r->pointer);
+
+ # print "pushing\n";
+ push @i, $i;
}
- else
+ # print "valid sub-items of $t are @{[keys %{$grammar->{_valid_items}}]}\n";
+ # print "<$tag> => <@i>\n";
+ unless (@i)
{
warn "$self->{file}:$r->{line}: $tag is not a sub-item of $t\n",
"Valid sub-items are ",
- join(", ", keys %{$grammar->{_valid_items}}), "\n"
+ join(", ", sort keys %{$grammar->{_valid_items}}), "\n"
unless substr($tag, 0, 1) eq "_";
# unless $tag eq "CONT" || $tag eq "CONC" || substr($tag, 0, 1) eq "_";
# TODO - should CONT and CONC be allowed anywhere?
}
+ if (@i > 1)
+ {
+ warn "$self->{file}:$r->{line}: Ambiguous tag $tag as sub-item of $t, ",
+ "found ", scalar @i, " matches. Using first.\n";
+ }
+ for my $i (@i)
+ {
+ $self->parse($r, $i);
+ last;
+ # TODO - are there any cases in which ambiguous tags could be present?
+ }
}
-# print "parsed\n";
+ # print "parsed\n";
}
sub collect_xrefs
{
my $self = shift;
- my ($callback) = @_;;
+ my ($callback) = @_;
$self->{gedcom}{xrefs}{$self->{xref}} = $self if defined $self->{xref};
$_->collect_xrefs($callback) for @{$self->{items}};
$self
@@ -192,15 +329,20 @@ sub resolve_xref
sub resolve
{
my $self = shift;
- my @x = map { ref($_) ? $_ : $self->resolve_xref($_) } @_;
+ my @x = map
+ {
+ ref($_)
+ ? $_
+ : do { my $x = $self->{gedcom}->resolve_xref($_); defined $x ? $x : () }
+ } @_;
wantarray ? @x : $x[0];
}
sub resolve_xrefs
{
my $self = shift;;
my ($callback) = @_;
- if (my $xref = $self->resolve_xref($self->{value}))
+ if (my $xref = $self->{gedcom}->resolve_xref($self->{value}))
{
$self->{value} = $xref;
}
@@ -249,14 +391,16 @@ sub validate_syntax
my $valid_items = $grammar->valid_items;
for my $tag (sort keys %$valid_items)
{
- my $g = $valid_items->{$tag};
- my $min = $g->{min};
- my $max = $g->{max};
- my $matches = delete $counts{$tag} || 0;
- my $msg = "$here has $matches $tag" . ($matches == 1 ? "" : "s");
- print " " x $I . "$msg - min is $min max is $max\n" if $D;
- $ok = 0, warn "$msg - minimum is $min\n" if $matches < $min;
- $ok = 0, warn "$msg - maximum is $max\n" if $matches > $max && $max;
+ for my $g (@{$valid_items->{$tag}})
+ {
+ my $min = $g->{min};
+ my $max = $g->{max};
+ my $matches = delete $counts{$tag} || 0;
+ my $msg = "