Permalink
Browse files

Version 1.13

  • Loading branch information...
1 parent aca2178 commit c418b738367c7a3555fb7b111b58dbafd9c28156 @pjcj committed Feb 21, 2005
Showing with 3,449 additions and 2,595 deletions.
  1. +11 −3 CHANGES
  2. +74 −25 Gedcom.pm
  3. +3 −3 Gedcom/CGI.pm
  4. +131 −0 Gedcom/Comparison.pm
  5. +3 −3 Gedcom/Event.pm
  6. +3 −3 Gedcom/Family.pm
  7. +3 −3 Gedcom/Grammar.pm
  8. +2,470 −2,470 Gedcom/Grammar_5_5.pm
  9. +4 −4 Gedcom/Individual.pm
  10. +2 −2 Gedcom/Item.pm
  11. +4 −4 Gedcom/LifeLines.pm
  12. +16 −9 Gedcom/Record.pm
  13. +4 −0 MANIFEST
  14. 0 META.yml
  15. +6 −8 Makefile.PL
  16. +1 −1 README
  17. +4 −1 TODO
  18. +3 −3 cgi-bin/gedcom.cgi
  19. +26 −4 ged
  20. +561 −0 gedcom-5.5.aft.grammar
  21. +1 −1 gedcom.vim
  22. +56 −0 gedcom_compare
  23. +6 −6 lines2perl
  24. +3 −3 parse_grammar
  25. +1 −1 royal.ged
  26. +1 −0 session.vim
  27. +10 −4 t/Basic.pm
  28. +3 −3 t/Engine.pm
  29. +3 −3 t/Lines.pm
  30. +1 −1 t/basic.t
  31. +1 −1 t/bias.t
  32. +2 −2 t/birthdates.t
  33. +12 −4 t/ged_create.t
  34. +1 −1 t/grammar_file.t
  35. +1 −1 t/lines.t
  36. +1 −1 t/lines/bias
  37. +4 −4 t/lines/bias.plx
  38. +2 −2 t/lines/lines.plx
  39. +2 −2 t/lines/namefreq.plx
  40. +1 −1 t/namefreq.t
  41. +1 −1 t/parse_grammar.t
  42. +1 −1 t/read_only.t
  43. +1 −1 t/resolve.t
  44. +1 −1 t/resolve_read_only.t
  45. +4 −4 tkged
View
14 CHANGES
@@ -157,7 +157,7 @@ Release 1.09 - 12th February 2001
- 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.
+ - Add Gedcom::CGI and cgi-bin/gedcom.cgi.
Release 1.10 - 5th March 2002
- Correct write_xml() documentation.
@@ -200,11 +200,11 @@ Release 1.10 - 5th March 2002
add_wife()
add_child()
- Add t/ged_create.t
- - Change Gedcom::Record::resolve so that unresolved xrefs do not return
+ - 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.
+ - Some reorganisation 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.
@@ -224,3 +224,11 @@ Release 1.12 - 2nd February 2003
- Ignore CRLF differences in tests.
- Tighten up and improve XML output.
- Add some missing functions to lines2perl (John S. Quarterman).
+
+Release 1.13 - 5th December 2003
+ - Add get_ functions to Gedcom.pm, and some tests for them.
+ - Gedcom::Individual::surname returns "" when no surname is found.
+ - Spell Gedcom::Lifelines::getstrmsg correctly.
+ - Use maniread() to read manifest.
+ - Add Gedcom::Comparison and gedcom_compare (unfinished).
+ - Add gedcom-5.5.aft.grammar for Ancestry Family Tree (Brad Rubenstein).
View
@@ -26,7 +26,7 @@ my %Top_tag_order;
BEGIN
{
- $VERSION = "1.12";
+ $VERSION = "1.13";
$Tags =
{
@@ -185,41 +185,57 @@ BEGIN
}
}
+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/^.*:://;
my $tag;
carp "Undefined subroutine $func called"
- if $func !~ /^add_(.*)$/ ||
- !($tag = $Funcs{lc $1}) ||
+ if $func !~ /^(add|get)_(.*)$/ ||
+ !($tag = $Funcs{lc $2}) ||
!exists $Top_tag_order{$tag};
no strict "refs";
- *$func = sub
+ if ($1 eq "add")
{
- my $self = shift;
- my $r = $self->add_record(tag => $tag);
- unless ($tag =~ /^(HEAD|TRLR)$/)
+ *$func = sub
{
- 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
- };
+ 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 =~ /^[^\W\d_]+(\d*)$/;
+ $x = $self->next_xref($x) unless length $1;
+ $r->{xref} = $x;
+ $self->{xrefs}{$r->{xref}} = $r;
+ }
+ $r
+ };
+ }
+ else
+ {
+ *$func = sub
+ {
+ my $self = shift;
+ my ($xref) = @_;
+ my $nxr = !defined $xref;
+ my @a = grep { $_->{tag} eq $tag && ($nxr || $_->{xref} eq $xref) }
+ @{$self->{record}->_items};
+ wantarray ? @a : $a[0]
+ };
+ }
goto &$func
}
-use Gedcom::Grammar 1.12;
-use Gedcom::Individual 1.12;
-use Gedcom::Family 1.12;
-use Gedcom::Event 1.12;
+use Gedcom::Grammar 1.13;
+use Gedcom::Individual 1.13;
+use Gedcom::Family 1.13;
+use Gedcom::Event 1.13;
sub new
{
@@ -323,7 +339,7 @@ sub new
for (split /\n/, <<'EOH')
This output was generated by Gedcom.pm.
Gedcom.pm is Copyright 1999-2003, Paul Johnson (pjcj@cpan.org)
-Version 1.12 - 2nd February 2003
+Version 1.13 - 6th December 2003
Gedcom.pm is free. It is licensed under the same terms as Perl itself.
@@ -377,7 +393,7 @@ sub write_xml
This output was generated by Gedcom.pm.
Gedcom.pm is Copyright 1999-2003, Paul Johnson (pjcj@cpan.org)
-Version 1.12 - 2nd February 2003
+Version 1.13 - 6th December 2003
Gedcom.pm is free. It is licensed under the same terms as Perl itself.
@@ -636,7 +652,7 @@ __END__
Gedcom - a module to manipulate Gedcom genealogy files
-Version 1.12 - 2nd February 2003
+Version 1.13 - 6th December 2003
=head1 SYNOPSIS
@@ -664,8 +680,15 @@ Version 1.12 - 2nd February 2003
my @families = $ged->families;
my $me = $ged->get_individual("Paul Johnson");
my $xref = $ged->next_xref("I");
-
my $record = $ged->add_header;
+ add_submitter
+ add_individual
+ add_family
+ add_note
+ add_repository
+ add_source
+ add_trailer
+ my $source = $ged->get_source("S1");
=head1 DESCRIPTION
@@ -1115,4 +1138,30 @@ The matches are:
Return the next available xref with the specified prefix.
+=head2 add_record
+
+ add_header
+ add_submitter
+ add_individual
+ add_family
+ add_note
+ add_repository
+ add_source
+ add_trailer
+
+Create and return a new record of the specified type.
+
+=head2 get_record
+
+ get_header
+ get_submitter
+ get_family
+ get_note
+ get_repository
+ get_source
+ get_trailer
+
+Return all records of the specified type. In scalar context just return the
+first record. If a parameter is passed in, just return records of that xref.
+
=cut
View
@@ -15,10 +15,10 @@ package Gedcom::CGI;
use CGI qw(:cgi :html);
-use Gedcom 1.12;
+use Gedcom 1.13;
use vars qw($VERSION);
-$VERSION = "1.12";
+$VERSION = "1.13";
sub gedcom
{
@@ -142,7 +142,7 @@ __END__
Gedcom::CGI - Basic CGI routines for Gedcom.pm
-Version 1.12 - 2nd February 2003
+Version 1.13 - 6th December 2003
=head1 SYNOPSIS
View
@@ -0,0 +1,131 @@
+# Copyright 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
+
+# documentation at __END__
+
+use strict;
+
+require 5.005;
+
+package Gedcom::Comparison;
+
+use vars qw($VERSION);
+$VERSION = "1.13";
+
+use Gedcom::Item 1.13;
+
+sub DESTROY {}
+
+sub new
+{
+ my $proto = shift;
+ my ($r1, $r2) = @_;
+
+ my $class = ref($proto) || $proto;
+
+ my $self =
+ {
+ record1 => $r1,
+ record2 => $r2,
+ };
+
+ bless $self, $class;
+
+ $self->compare
+}
+
+
+sub compare
+{
+ my $self = shift;
+
+ $self->{$_} = [] for qw( identical conflict only1 only2 );
+
+ my $r1 = $self->{record1};
+ my $r2 = $self->{record2};
+
+ my ($v1, $v2) = ($r1->{value}, $r2->{value});
+ $self->{value_match} = !(defined $v1 ^ defined $v2);
+ $self->{value_match} &&= $v1 eq $v2 if defined $v1;
+ # $self->{value_match} = defined $r1->{value}
+ # ? defined $r2->{value}
+ # ? r1->value eq $r2->value
+ # : 0
+ # : !defined $r2->{value};
+
+ my @r1 = $r1->items;
+ my %r2 = map { $_->tag => $_ } $r2->items;
+
+ TAG1:
+ for my $i1 (@r1)
+ {
+ my $tag = $i1->tag;
+ for my $i2 (keys %r2)
+ {
+ if ($i2 eq $tag)
+ {
+ my $comp = Gedcom::Comparison->new($i1, delete $r2{$i2});
+ push @{$self->{$comp->identical ? "identical" : "conflict"}}, $comp;
+ next TAG1
+ }
+ }
+ push @{$self->{only1}}, $i1;
+ }
+
+ $self->{only2} = [ values %r2 ];
+
+ $self
+}
+
+
+sub identical
+{
+ my $self = shift;
+ $self->{value_match} &&
+ !@{$self->{only1}} &&
+ !@{$self->{only2}} &&
+ !@{$self->{conflict}}
+}
+
+sub print
+{
+ my $self = shift;
+
+ print $self->identical ? "" : "not ";
+ print "identical\n";
+
+ printf "value match: %d\n", $self->{value_match};
+ printf "identical: %d\n", scalar @{$self->{identical}};
+ printf "conflict: %d\n", scalar @{$self->{conflict}};
+ printf "only1: %d\n", scalar @{$self->{only1}};
+ printf "only2: %d\n", scalar @{$self->{only2}};
+
+ $self->{record1}->print;
+ $self->{record2}->print;
+
+ $_->print for @{$self->{conflict}};
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Gedcom::Comparison - a module to compare Gedcom records
+
+Version 1.13 - 6th December 2003
+
+=head1 SYNOPSIS
+
+ use Gedcom::Comparison;
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=end
View
@@ -13,10 +13,10 @@ require 5.005;
package Gedcom::Event;
-use Gedcom::Record 1.12;
+use Gedcom::Record 1.13;
use vars qw($VERSION @ISA);
-$VERSION = "1.12";
+$VERSION = "1.13";
@ISA = qw( Gedcom::Record );
# sub type
@@ -45,7 +45,7 @@ __END__
Gedcom::Event - a module to manipulate Gedcom events
-Version 1.12 - 2nd February 2003
+Version 1.13 - 6th December 2003
=head1 SYNOPSIS
View
@@ -13,10 +13,10 @@ require 5.005;
package Gedcom::Family;
-use Gedcom::Record 1.12;
+use Gedcom::Record 1.13;
use vars qw($VERSION @ISA);
-$VERSION = "1.12";
+$VERSION = "1.13";
@ISA = qw( Gedcom::Record );
sub husband
@@ -112,7 +112,7 @@ __END__
Gedcom::Family - a module to manipulate Gedcom families
-Version 1.12 - 2nd February 2003
+Version 1.13 - 6th December 2003
=head1 SYNOPSIS
Oops, something went wrong.

0 comments on commit c418b73

Please sign in to comment.