Gedcom-1.19/0000755000175000017500000000000012204002636011273 5ustar pjcjpjcjGedcom-1.19/gedcom-5.5.grammar0000644000175000017500000003355712204002473014422 0ustar pjcjpjcj GEDCOM: = 0 <
> {1:1} 0 <> {0:1} 0 <> {0:M} 0 TRLR {1:1} HEADER: = n HEAD {1:1} +1 SOUR {1:1} +2 VERS {0:1} +2 NAME {0:1} +2 CORP {0:1} +3 <> {0:1} +2 DATA {0:1} +3 DATE {0:1} +3 COPR {0:1} +1 DEST {0:1*} +1 DATE {0:1} +2 TIME {0:1} +1 SUBM @@ {1:1} +1 SUBN @@ {0:1} +1 FILE {0:1} +1 COPR {0:1} +1 GEDC {1:1} +2 VERS {1:1} +2 FORM {1:1} +1 CHAR {1:1} +2 VERS {0:1} +1 LANG {0:1} +1 PLAC {0:1} +2 FORM {1:1} +1 NOTE {0:1} +2 CONT {0:M} +2 CONC {0:M} RECORD: = [ n <> {1:1} | n <> {1:1} | n <> {1:M} | n <> {1:1} | n <> {1:1} | n <> {1:1} | n <> {1:1} | n <> {1:1} ] FAM_RECORD: = n @@ FAM {1:1} +1 <> {0:M} +2 HUSB {0:1} +3 AGE {1:1} +2 WIFE {0:1} +3 AGE {1:1} +1 HUSB @@ {0:1} +1 WIFE @@ {0:1} +1 CHIL @@ {0:M} +1 NCHI {0:1} +1 SUBM @@ {0:M} +1 <> {0:M} +1 <> {0:M} +1 <> {0:M} +1 <> {0:M} +1 REFN {0:M} +2 TYPE {0:1} +1 RIN {0:1} +1 <> {0:1} INDIVIDUAL_RECORD: = n @@ INDI {1:1} +1 RESN {0:1} +1 <> {0:M} +1 SEX {0:1} +1 <> {0:M} +1 <> {0:M} +1 <> {0:M} +1 <> {0:M} +1 <> {0:M} +1 <> {0:1} +1 SUBM @@ {0:M} +1 <> {0:M} +1 ALIA @@ {0:M} +1 ANCI @@ {0:M} +1 DESI @@ {0:M} +1 <> {0:M} +1 <> {0:M} +1 <> {0:M} +1 RFN {0:1} +1 AFN {0:1} +1 REFN {0:M} +2 TYPE {0:1} +1 RIN {0:1} +1 <> {0:1} MULTIMEDIA_RECORD: = n @@ OBJE {1:1} +1 FORM {1:1} +1 TITL {0:1} +1 <> {0:M} +1 BLOB {1:1} +2 CONT {1:M} +1 OBJE @@ {0:1} +1 REFN {0:M} +2 TYPE {0:1} +1 RIN {0:1} +1 <> {0:1} NOTE_RECORD: = n @@ NOTE {1:1} +1 CONC {0:M} +1 CONT {0:M} +1 <> {0:M} +1 REFN {0:M} +2 TYPE {0:1} +1 RIN {0:1} +1 <> {0:1} REPOSITORY_RECORD: = n @@ REPO {1:1} +1 NAME {0:1} +1 <> {0:1} +1 <> {0:M} +1 REFN {0:M} +2 TYPE {0:1} +1 RIN {0:1} +1 <> {0:1} SOURCE_RECORD: = n @@ SOUR {1:1} +1 DATA {0:1} +2 EVEN {0:M} +3 DATE {0:1} +3 PLAC {0:1} +2 AGNC {0:1} +2 <> {0:M} +1 AUTH {0:1} +2 ABBR {0:1} +2 CONT {0:M} +2 CONC {0:M} +1 TITL {0:1} +2 CONT {0:M} +2 CONC {0:M} +1 ABBR {0:1} +1 PUBL {0:1} +2 CONT {0:M} +2 CONC {0:M} +1 TEXT {0:1} +2 CONT {0:M} +2 CONC {0:M} +1 QUAY {0:1} +1 <> {0:1} +1 <> {0:M} +1 <> {0:M} +1 REFN {0:M} +2 TYPE {0:1} +1 RIN {0:1} +1 <> {0:1} SUBMISSION_RECORD: = n @@ SUBN {1:1] +1 SUBM @@ {0:1} +1 FAMF {0:1} +1 TEMP {0:1} +1 ANCE {0:1} +1 DESC {0:1} +1 ORDI {0:1} +1 RIN {0:1} SUBMITTER_RECORD: = n @@ SUBM {1:1} +1 NAME {1:1} +1 <> {0:1} +1 <> {0:M} +1 LANG {0:3} +1 RFN {0:1} +1 RIN {0:1} +1 <> {0:1} ADDRESS_STRUCTURE: = n ADDR {0:1} +1 CONT {0:M} +1 ADR1 {0:1} +1 ADR2 {0:1} +1 CITY {0:1} +1 STAE {0:1} +1 POST {0:1} +1 CTRY {0:1} n PHON {0:3} ASSOCIATION_STRUCTURE: = n ASSO @@ {0:M} +1 TYPE {1:1} +1 RELA {1:1} +1 <> {0:M} +1 <> {0:M} CHANGE_DATE: = n CHAN {1:1} +1 DATE {1:1} +2 TIME {0:1} +1 <> {0:M} CHILD_TO_FAMILY_LINK: = n FAMC @@ {1:1} +1 PEDI {0:M} +1 <> {0:M} EVENT_DETAIL: = n TYPE {0:1} n DATE {0:1} n <> {0:1} n <> {0:1} n AGE {0:1} n AGNC {0:1} n CAUS {0:1} n <> {0:M} n <> {0:M} n <> {0:M} FAMILY_EVENT_STRUCTURE: = [ n ANUL {1:1} +1 <> {0:1} | n CENS {1:1} +1 <> {0:1} | n DIV {1:1} +1 <> {0:1} | n DIVF {1:1} +1 <> {0:1} | n ENGA {1:1} +1 <> {0:1} | n MARR {1:1} +1 <> {0:1} | n MARB {1:1} +1 <> {0:1} | n MARC {1:1} +1 <> {0:1} | n MARL {1:1} +1 <> {0:1} | n MARS {1:1} +1 <> {0:1} | n EVEN {1:1} +1 <> {0:1} ] INDIVIDUAL_ATTRIBUTE_STRUCTURE: = [ n CAST {1:1} +1 <> {0:1} | n DSCR {1:1} +1 <> {0:1} | n EDUC {1:1} +1 <> {0:1} | n IDNO {1:1}* +1 <> {0:1} | n NATI {1:1} +1 <> {0:1} | n NCHI {1:1} +1 <> {0:1} | n NMR {1:1} +1 <> {0:1} | n OCCU {1:1} +1 <> {0:1} | n PROP {1:1} +1 <> {0:1} | n RELI {1:1} +1 <> {0:1} | n RESI {1:1} +1 <> {0:1} | n SSN {0:1} +1 <> {0:1} | n TITL {1:1} +1 <> {0:1} ] INDIVIDUAL_EVENT_STRUCTURE: = [ n BIRT {1:1} +1 <> {0:1} +1 FAMC @@ {0:1} | n CHR {1:1} +1 <> {0:1} +1 FAMC @@ {0:1} | n DEAT {1:1} +1 <> {0:1} | n BURI {1:1} +1 <> {0:1} | n CREM {1:1} +1 <> {0:1} | n ADOP {1:1} +1 <> {0:1} +1 FAMC @@ {0:1} +2 ADOP {0:1} | n BAPM {1:1} +1 <> {0:1} | n BARM {1:1} +1 <> {0:1} | n BASM {1:1} +1 <> {0:1} | n BLES {1:1} +1 <> {0:1} | n CHRA {1:1} +1 <> {0:1} | n CONF {1:1} +1 <> {0:1} | n FCOM {1:1} +1 <> {0:1} | n ORDN {1:1} +1 <> {0:1} | n NATU {1:1} +1 <> {0:1} | n EMIG {1:1} +1 <> {0:1} | n IMMI {1:1} +1 <> {0:1} | n CENS {1:1} +1 <> {0:1} | n PROB {1:1} +1 <> {0:1} | n WILL {1:1} +1 <> {0:1} | n GRAD {1:1} +1 <> {0:1} | n RETI {1:1} +1 <> {0:1} | n EVEN {1:1} +1 <> {0:1} ] LDS_INDIVIDUAL_ORDINANCE: = [ n BAPL {1:1} +1 STAT {0:1} +1 DATE {0:1} +1 TEMP {0:1} +1 PLAC {0:1} +1 <> {0:M} +1 <> {0:M} | n CONL {1:1} +1 STAT {0:1} +1 DATE {0:1} +1 TEMP {0:1} +1 PLAC {0:1} +1 <> {0:M} +1 <> {0:M} | n ENDL {1:1} +1 STAT {0:1} +1 DATE {0:1} +1 TEMP {0:1} +1 PLAC {0:1} +1 <> {0:M} +1 <> {0:M} | n SLGC {1:1} +1 STAT {0:1} +1 DATE {0:1} +1 TEMP {0:1} +1 PLAC {0:1} +1 FAMC @@ {1:1} +1 <> {0:M} +1 <> {0:M} ] LDS_SPOUSE_SEALING: = n SLGS {1:1} +1 STAT {0:1} +1 DATE {0:1} +1 TEMP {0:1} +1 PLAC {0:1} +1 <> {0:M} +1 <> {0:M} MULTIMEDIA_LINK: = [ n OBJE @@ {1:1} | n OBJE {1:1} +1 FORM {1:1} +1 TITL {0:1} +1 FILE {1:1} +1 <> {0:M} ] NOTE_STRUCTURE: = [ n NOTE @@ {1:1} +1 <> {0:M} | n NOTE {1:1} +1 CONC {0:M} +1 CONT {0:M} +1 <> {0:M} ] PERSONAL_NAME_STRUCTURE: = n NAME {1:1} +1 NPFX {0:1} +1 GIVN {0:1} +1 NICK {0:1} +1 SPFX {0:1} +1 SURN {0:1} +1 NSFX {0:1} +1 <> {0:M} +1 <> {0:M} PLACE_STRUCTURE: = n PLAC {1:1} +1 FORM {0:1} +1 <> {0:M} +1 <> {0:M} EVENT_DEFINITION: = n _EVENT_DEFN {1:1} +1 TYPE {0:1} +1 TITL {0:1} +2 ABBR {0:1} +1 ABBR {0:1} SOURCE_CITATION: = [ n SOUR @@ {1:1} +1 PAGE {0:1} +2 CONC {0:M} +2 CONT {0:M} +1 REFN {0:1} +1 EVEN {0:1} +2 ROLE {0:1} +1 DATA {0:1} +2 DATE {0:1} +2 TEXT {0:M} +3 CONC {0:M} +3 CONT {0:M} +1 QUAY {0:1} +1 <> {0:M} +1 <> {0:M} | n SOUR {1:1} +1 CONC {0:M} +1 CONT {0:M} +1 TEXT {0:M} +2 CONC {0:M} +2 CONT {0:M} +1 <> {0:M} ] SOURCE_REPOSITORY_CITATION: = n REPO @@ {1:1} +1 <> {0:M} +1 CALN {0:M} +2 MEDI {0:1} SPOUSE_TO_FAMILY_LINK: = n FAMS @@ {1:1} +1 <> {0:M} Gedcom-1.19/TODO0000644000175000017500000000234112204002473011762 0ustar pjcjpjcj[pjcj] - Beef up the documentation including a more in depth tutorial. The new(ish) add() functionality needs a tutorial. - Beef up the testsuite, including more LifeLines tests. - Make ged into a real program, rather than just a little demo. - Rewrite tkged. - Provide functions to merge data. - Finish LifeLines.pm. - Add new LifeLines functions. - Speed ups. - Turn children from an array into a hash: key is tag, value is array of items. - Separate REs for parsing grammar files and gedcom files. Note: I tried this but it didn't seem to provide much of a benefit. - Conversion of notes to and from top level records - Include names in index file? - Document add_xxx functions. - Integrate functions I've been sent and write new ones suggested. - Use Gedcom::Date. - Provide method to tag a subset of the records and copy them en masse keeping all references intact. [bricas] - tidy up Makefile.PL + remove "if 0" sections + perlbug stuff truly necessary? + remove version and date munging + pick through remaining MY::postamble() stuff + better way to handle optional deps? - tidy up dist dirs + installable script in script/ + related scripts/files in another folder (etc/?) + must sure test-related files stay under t/ Gedcom-1.19/.travis.yml0000644000175000017500000000043112161400025013376 0ustar pjcjpjcjlanguage: perl perl: - "5.10" - "5.12" - "5.14" - "5.16" - "5.18" before_install: cpanm -n Devel::Cover::Report::Coveralls script: perl Makefile.PL && make && cover -test -report coveralls notifications: email: on_success: always on_failure: always Gedcom-1.19/META.json0000664000175000017500000000220212204002636012712 0ustar pjcjpjcj{ "abstract" : "Interface to genealogy GEDCOM files", "author" : [ "Paul Johnson (paul@pjcj.net)" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.120921", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Gedcom", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "runtime" : { "recommends" : { "Date::Manip" : "0", "Parse::RecDescent" : "0", "Roman" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/pjcj/Gedcom.pm/issues" }, "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "type" : "git", "url" : "http://github.com/pjcj/Gedcom.pm", "web" : "http://github.com/pjcj/Gedcom.pm" }, "x_mailing_list" : "http://lists.perl.org/list/perl-gedcom.html" }, "version" : "1.19" } Gedcom-1.19/t/0000755000175000017500000000000012204002636011536 5ustar pjcjpjcjGedcom-1.19/t/ws_json.t0000644000175000017500000000705412204002474013413 0ustar pjcjpjcj#!/usr/bin/perl -w # Copyright 1999-2013, Paul Johnson (paul@pjcj.net) # 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.19 - 18th August 2013 use strict; use lib -d "t" ? "t" : ".."; BEGIN { unless ($ENV{DEVEL_COVER_WS_TESTS}) { eval "use Test::More skip_all => " . "q[\$DEVEL_COVER_WS_TESTS is not set]"; } eval q{ use 5.006; use Apache::Test ":withtestmore"; use Apache::TestUtil; use LWP::Simple; use Test::JSON; }; if (my $e = $@) { eval "use Test::More skip_all => " . "q[mod_perl or Test::JSON not fully installed]"; # "q[mod_perl or Test::JSON not fully installed [$e]]"; } } use Test::More; Apache::TestRequest::module('default'); my $config = Apache::Test::config(); my $hostport = Apache::TestRequest::hostport($config) || ""; my $ws = "/ws/json/royal"; my $root = "http://$hostport$ws"; sub ws { join "", map "$ws/$_\n", @_ } sub rs { my $r = join "", map {chomp(my $t = $_); "$t\n" } @_; chomp $r; $r } my @tests = ( [ "?search=Elizabeth_II", ws "I9" ], [ "/i9/name", rs <<'EOR' ], {"name":"Elizabeth_II Alexandra Mary /Windsor/"} EOR [ "/i9/children", ws qw( I11 I15 I19 I23 ) ], [ "/i9/birth/date", rs <<'EOR' ], {"date":"Wednesday, 21st April 1926"} EOR [ "/i9/birth", rs <<'EOR' ], {"level":1,"tag":"BIRT","items":[{"level":2,"pointer":"","value":"Wednesday, 21st April 1926","tag":"DATE","items":[]},{"level":2,"pointer":"","value":"17 Bruton St.,London,W1,England","tag":"PLAC","items":[]}]} EOR [ "/i9", rs <<'EOR' ], {"rec":{"xref":"I9","level":0,"tag":"INDI","items":[{"level":1,"pointer":"","value":"Elizabeth_II Alexandra Mary/Windsor/","tag":"NAME","items":[]},{"level":1,"pointer":"","value":"Queen of England","tag":"TITL","items":[]},{"level":1,"pointer":"","value":"F","tag":"SEX","items":[]},{"level":1,"tag":"BIRT","items":[{"level":2,"pointer":"","value":"Wednesday, 21st April 1926","tag":"DATE","items":[]},{"level":2,"pointer":"","value":"17 Bruton St.,London,W1,England","tag":"PLAC","items":[]}]},{"level":1,"pointer":1,"value":"F6","tag":"FAMS","items":[]},{"level":1,"pointer":1,"value":"F4","tag":"FAMC","items":[]},{"level":1,"pointer":"","value":10,"tag":"RIN","items":[]}]}} EOR [ "/i0", "Can't get record [i0]\n" ], [ "/I9/__error__", "Invalid action [__error__]\n" ], [ "", "No xref or parameters specified\n" ], ); plan tests => scalar @tests + 2 + grep substr($_->[1], 0, 1) eq "{", @tests; for (@tests) { my $q = $root . $_->[0]; # t_debug("-- $q"); # t_debug("++ ", get($q)); my $result = get($q); my $match = $_->[1]; my $json = substr($match, 0, 1) eq "{"; # print "match [$json][$match]\n"; is_valid_json $result, "$q well formed" if $json; $json ? is_json $result, $match, "$q json matches" : is $result, $match, $q; } is get("http://$hostport/ws/json/"), "No GEDCOM file specified\n", "No GEDCOM file specified"; like get("http://$hostport/ws/json/__error__"), qr!Can't open file .*/__error__.ged: No such file or directory!, "GEDCOM file does not exist"; Gedcom-1.19/t/ws_plain.t0000644000175000017500000000505312204002474013542 0ustar pjcjpjcj#!/usr/bin/perl -w # Copyright 1999-2013, Paul Johnson (paul@pjcj.net) # 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.19 - 18th August 2013 use strict; use lib -d "t" ? "t" : ".."; BEGIN { unless ($ENV{DEVEL_COVER_WS_TESTS}) { eval "use Test::More skip_all => " . "q[\$DEVEL_COVER_WS_TESTS is not set]"; } eval q{ use 5.006; use Apache::Test ":withtestmore"; use Apache::TestUtil; use LWP::Simple; }; if (my $e = $@) { eval "use Test::More skip_all => q[mod_perl not fully installed]"; #eval "use Test::More skip_all => q[mod_perl not fully installed [$e]]"; } } use Test::More; Apache::TestRequest::module('default'); my $config = Apache::Test::config(); my $hostport = Apache::TestRequest::hostport($config) || ""; my $ws = "/ws/plain/royal"; my $root = "http://$hostport$ws"; sub ws { join "", map "$ws/$_\n", @_ } sub rs { join "", map {chomp(my $t = $_); "$t\n" } @_ } my @tests = ( [ "?search=Elizabeth_II", ws "I9" ], [ "/i9/name", rs "Elizabeth_II Alexandra Mary /Windsor/" ], [ "/i9/children", ws qw( I11 I15 I19 I23 ) ], [ "/i9/birth/date", "Wednesday, 21st April 1926\n" ], [ "/i9/birth", rs <<'EOR' ], 1 BIRT 2 DATE Wednesday, 21st April 1926 2 PLAC 17 Bruton St.,London,W1,England EOR [ "/i9", rs <<'EOR' ], 0 @I9@ INDI 1 NAME Elizabeth_II Alexandra Mary/Windsor/ 1 TITL Queen of England 1 SEX F 1 BIRT 2 DATE Wednesday, 21st April 1926 2 PLAC 17 Bruton St.,London,W1,England 1 FAMS @F6@ 1 FAMC @F4@ 1 RIN 10 EOR [ "/i0", "Can't get record [i0]\n" ], [ "/I9/__error__", "Invalid action [__error__]\n" ], [ "", "No xref or parameters specified\n" ], ); plan tests => scalar @tests + 2; for (@tests) { my $q = $root . $_->[0]; # t_debug("-- $q"); # t_debug("++ ", get($q)); is get($q), $_->[1], $q; } is get("http://$hostport/ws/plain/"), "No GEDCOM file specified\n", "No GEDCOM file specified"; like get("http://$hostport/ws/plain/__error__"), qr!Can't open file .*/__error__.ged: No such file or directory!, "GEDCOM file does not exist"; Gedcom-1.19/t/basic.t0000644000175000017500000000061112204002474013002 0ustar pjcjpjcj#!/usr/local/bin/perl -w # Copyright 1998-2013, Paul Johnson (paul@pjcj.net) # 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.19 - 18th August 2013 use strict; use lib -d "t" ? "t" : ".."; use Basic (resolve => "unresolve_xrefs", read_only => 0); Gedcom-1.19/t/Lines.pm0000644000175000017500000000446212204002474013154 0ustar pjcjpjcj#!/usr/local/bin/perl -w # Copyright 1999-2013, Paul Johnson (paul@pjcj.net) # 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.19 - 18th August 2013 use strict; require 5.005; package Lines; use File::Basename; use Test; use vars qw($VERSION); $VERSION = "1.19"; use Gedcom 1.19; sub test { my $class = shift; my (%args) = @_; die "tests not specified" unless defined $args{tests}; plan tests => $args{tests}; $args{gedcom_file} = (-d "t" ? "" : "../") ."royal.ged" unless defined $args{gedcom_file}; die "report not specified" unless defined $args{report}; if (defined $args{report_command}) { $args{lines} = "/home/pjcj/ged/other/lines/bin/lines302" unless defined $args{lines}; if ( -x $args{lines} && open(L, "|$args{lines}")) { my $db = basename($args{gedcom_file}, "\.ged"); system "rm -rf $db"; print L "$db\n"; print L "yur$args{gedcom_file}\n "; print L "r$args{report}\n"; print L "$args{report_command}"; print L "q"; close(L) or die "Can't close <$args{lines}>"; print "\n"; } } ok 1; $args{perl_program} = "$args{report}.plx" unless defined $args{perl_program}; if ($args{generate}) { system((-d "t" ? "" : "../") . "lines2perl -quiet $args{report} > $args{perl_program}"); ok $? == 0; } else { ok 1; } $args{lines_report} = "$args{report}.l" unless defined $args{lines_report}; $args{perl_report} = "$args{report}.p" unless defined $args{perl_report}; die "perl_command not specified" unless defined $args{perl_command}; my $command = "|$^X " . (-d "t" ? "" : "-I .. ") . "$args{perl_program} -quiet -gedcom_file $args{gedcom_file} " . "> $args{perl_report}"; open P, $command or die "Can't run <$command>"; select P; $| = 1; print P $args{perl_command}; close(P) or die "Can't close <$args{perl_program}>"; ok 1; # check the gedcom file is correct ok open LO, $args{lines_report}; ok open PO, $args{perl_report}; ok , $_ while ; ok eof PO; ok close PO; ok close LO; # ok unlink $args{perl_report}; } sub import { my $class = shift; $class->test(@_) if @_; } 1; Gedcom-1.19/t/birthdates.t0000755000175000017500000001352312204002474014063 0ustar pjcjpjcjuse strict; use warnings; use Test::More tests => 162; use Gedcom; sub date_eq { my @dates = @_; s{[\r\n]+$}{\n} for @dates; is( $dates[ 0 ], $dates[ 1 ] ); } my $ged = Gedcom->new( gedcom_file => 'royal.ged', readonly => 1 ); isa_ok( $ged, 'Gedcom' ); my @birthdates = ; { my @dates = @birthdates; # Look at each individual. for my $i ($ged->individuals) { # Look at each birth record. # There will generally be one birth record, but there may be none, # or more than one. for my $b ($i->birth) { # Look at each date in the birth record. # Again, there will generally be only one date, but there may be # none, or more than one. for my $d ($b->date) { date_eq( $i->name . " was born on $d\n", shift @dates ); } } } } { # Here's a newer, better way of doing the same thing. my @dates = @birthdates; for my $i ($ged->individuals) { for my $d ($i->get_value(qw(birth date))) { date_eq($i->name . " was born on $d\n", shift @dates); } } } date_eq($ged->get_individual("Edward_VIII")->get_value(qw(birth date)), "Saturday, 23rd June 1894"); my $i = $ged->get_individual("B1 C1"); # list context is_deeply( [ $i->get_value("birth date") ], [ "Saturday, 1st January 2000", "Sunday, 2nd January 2000" ] ); # scalar context date_eq( scalar $i->get_value("birth date"), "Saturday, 1st January 2000" ); date_eq($i->get_value(["birth", 2], "date"), "Sunday, 2nd January 2000"); date_eq($i->birth(2)->date, "Sunday, 2nd January 2000"); __DATA__ Edward_VII /Wettin/ was born on Tuesday, 9th November 1841 Alexandra of_Denmark "Alix" // was born on Sunday, 1st December 1844 George_V /Windsor/ was born on Saturday, 3rd June 1865 Mary_of_Teck (May) // was born on Sunday, 26th May 1867 Edward_VIII /Windsor/ was born on Saturday, 23rd June 1894 Bessiewallis /Warfield/ was born on 1896 George_VI /Windsor/ was born on Saturday, 14th December 1895 Elizabeth Angela Marguerite /Bowes-Lyon/ was born on Saturday, 4th August 1900 Elizabeth_II Alexandra Mary /Windsor/ was born on Wednesday, 21st April 1926 Philip /Mountbatten/ was born on Friday, 10th June 1921 Charles Philip Arthur /Windsor/ was born on Sunday, 14th November 1948 Diana Frances /Spencer/ was born on Saturday, 1st July 1961 William Arthur Philip /Windsor/ was born on Monday, 21st June 1982 Henry Charles Albert /Windsor/ was born on Saturday, 15th September 1984 Anne Elizabeth Alice /Windsor/ was born on Tuesday, 15th August 1950 Mark Anthony Peter /Phillips/ was born on Wednesday, 22nd September 1948 Peter Mark Andrew /Phillips/ was born on Tuesday, 15th November 1977 Zara Anne Elizabeth /Phillips/ was born on Friday, 15th May 1981 Andrew Albert Christian /Windsor/ was born on Friday, 19th February 1960 Sarah Margaret /Ferguson/ was born on Thursday, 15th October 1959 Beatrice Elizabeth Mary /Windsor/ was born on Monday, 8th August 1988 Eugenie Victoria Helena /Windsor/ was born on Friday, 23rd March 1990 Edward Anthony Richard /Windsor/ was born on Tuesday, 10th March 1964 Margaret Rose /Windsor/ was born on Thursday, 21st August 1930 Anthony Charles Robert /Armstrong-Jones/ was born on Friday, 7th March 1930 David Albert Charles /Armstrong-Jones/ was born on Friday, 3rd November 1961 Sarah Frances Elizabeth /Armstrong-Jones/ was born on Friday, 1st May 1964 Mary /Windsor/ was born on Sunday, 25th April 1897 Henry George Charles /Lascelles/ was born on 1882 George Earl_of_Harewood /Lascelles/ was born on 1923 Marion (Maria) Donata /Stein/ was born on 1926 David /Lascelles/ was born on 1950 Emily // was born on 1976 Benjamin // was born on 1978 Alexander /Lascelles/ was born on 1980 Edward /Lascelles/ was born on 1982 James /Lascelles/ was born on 1953 Sophie /Lascelles/ was born on 1973 Rowan /Lascelles/ was born on 1977 Jeremy /Lascelles/ was born on 1955 Thomas /Lascelles/ was born on 1982 Ellen /Lascelles/ was born on 1984 Patricia /Tuckwell/ was born on 1923 Mark /Lascelles/ was born on 1964 Gerald /Lascelles/ was born on 1924 Angela /Dowding/ was born on 1919 Henry /Lascelles/ was born on 1953 Elizabeth Collingwood /Colvin/ was born on 1924 Martin /Lascelles/ was born on 1963 Henry William Frederick /Windsor/ was born on Saturday, 31st March 1900 Alice Christabel /Montagu-Douglas/ was born on Wednesday, 25th December 1901 William Henry Andrew /Windsor/ was born on Thursday, 18th December 1941 Richard Alexander Walter /Windsor/ was born on Saturday, 26th August 1944 Birgitte of_Denmark /von_Deurs/ was born on 1947 Alexander Patrick Gregers // was born on Thursday, 24th October 1974 Davina Elizabeth Alice /Windsor/ was born on Saturday, 19th November 1977 Rose Victoria Birgitte /Windsor/ was born on Saturday, 1st March 1980 George Edward Alexander /Windsor/ was born on Saturday, 20th December 1902 Marina of_Greece // was born on Friday, 30th November 1906 Edward George Nicholas /Windsor/ was born on Monday, 9th September 1935 Katharine /Worsley/ was born on 1933 George Philip of_St._Andrews /Windsor/ was born on Tuesday, 26th June 1962 Sylvana /Tomaselli/ was born on ABT 1957 Helen Marina Lucy /Windsor/ was born on Tuesday, 28th April 1964 Nicholas Charles Edward /Windsor/ was born on Saturday, 25th July 1970 Alexandra /Windsor/ was born on Friday, 25th December 1936 Angus /Ogilvy/ was born on 1928 James Robert Bruce /Ogilvy/ was born on Saturday, 29th February 1964 Marina Victoria Alexandra /Ogilvy/ was born on Sunday, 31st July 1966 Paul /Mowatt/ was born on ABT 1962 /Mowatt/ was born on Saturday, 26th May 1990 Michael /Windsor/ was born on Saturday, 4th July 1942 Marie-Christine /von_Reibnitz/ was born on Monday, 15th January 1945 Frederick /Windsor/ was born on Friday, 6th April 1979 Gabriella Marina Alexandra /Windsor/ was born on Thursday, 23rd April 1981 John Charles Francis /Windsor/ was born on Wednesday, 12th July 1905 B1 C1 was born on Saturday, 1st January 2000 B1 C1 was born on Sunday, 2nd January 2000 Gedcom-1.19/t/resolve.t0000755000175000017500000000060712204002474013410 0ustar pjcjpjcj#!/usr/local/bin/perl -w # Copyright 1999-2013, Paul Johnson (paul@pjcj.net) # 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.19 - 18th August 2013 use strict; use lib -d "t" ? "t" : ".."; use Basic (resolve => "resolve_xrefs", read_only => 0); Gedcom-1.19/t/ws_xml.t0000644000175000017500000000532712204002474013243 0ustar pjcjpjcj#!/usr/bin/perl -w # Copyright 1999-2013, Paul Johnson (paul@pjcj.net) # 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.19 - 18th August 2013 use strict; use lib -d "t" ? "t" : ".."; BEGIN { unless ($ENV{DEVEL_COVER_WS_TESTS}) { eval "use Test::More skip_all => " . "q[\$DEVEL_COVER_WS_TESTS is not set]"; } eval q{ use 5.006; use Apache::Test ":withtestmore"; use Apache::TestUtil; use LWP::Simple; }; if (my $e = $@) { eval "use Test::More skip_all => q[mod_perl not fully installed]"; #eval "use Test::More skip_all => q[mod_perl not fully installed [$e]]"; } } use Test::More; Apache::TestRequest::module('default'); my $config = Apache::Test::config(); my $hostport = Apache::TestRequest::hostport($config) || ""; my $ws = "/ws/xml/royal"; my $root = "http://$hostport$ws"; sub ws { join "", map "$ws/$_\n", @_ } sub rs { join "", map {chomp(my $t = $_); "$t\n" } @_ } my @tests = ( [ "?search=Elizabeth_II", ws "I9" ], [ "/i9/name", rs <<'EOR' ], Elizabeth_II Alexandra Mary /Windsor/ EOR [ "/i9/children", ws qw( I11 I15 I19 I23 ) ], [ "/i9/birth/date", rs <<'EOR' ], Wednesday, 21st April 1926 EOR [ "/i9/birth", rs <<'EOR' ], Wednesday, 21st April 1926 17 Bruton St.,London,W1,England EOR [ "/i9", rs <<'EOR' ], Elizabeth_II Alexandra Mary/Windsor/ Queen of England F Wednesday, 21st April 1926 17 Bruton St.,London,W1,England 10 EOR [ "/i0", "Can't get record [i0]\n" ], [ "/I9/__error__", "Invalid action [__error__]\n" ], [ "", "No xref or parameters specified\n" ], ); plan tests => scalar @tests + 2; for (@tests) { my $q = $root . $_->[0]; # t_debug("-- $q"); # t_debug("++ ", get($q)); is get($q), $_->[1], $q; } is get("http://$hostport/ws/xml/"), "No GEDCOM file specified\n", "No GEDCOM file specified"; like get("http://$hostport/ws/xml/__error__"), qr!Can't open file .*/__error__.ged: No such file or directory!, "GEDCOM file does not exist"; Gedcom-1.19/t/read_only.t0000755000175000017500000000061112204002474013700 0ustar pjcjpjcj#!/usr/local/bin/perl -w # Copyright 1999-2013, Paul Johnson (paul@pjcj.net) # 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.19 - 18th August 2013 use strict; use lib -d "t" ? "t" : ".."; use Basic (resolve => "unresolve_xrefs", read_only => 1); Gedcom-1.19/t/grammar_file.t0000755000175000017500000000071512204002474014356 0ustar pjcjpjcj#!/usr/local/bin/perl -w # Copyright 1998-2013, Paul Johnson (paul@pjcj.net) # 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.19 - 18th August 2013 use strict; use lib -d "t" ? "t" : ".."; use Basic (resolve => "unresolve_xrefs", read_only => 0, grammar_file => "gedcom-5.5.grammar"); Gedcom-1.19/t/parse_grammar.t0000755000175000017500000000074012204002474014547 0ustar pjcjpjcj#!/usr/local/bin/perl -w # Copyright 1998-2013, Paul Johnson (paul@pjcj.net) # 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.19 - 18th August 2013 use strict; use lib -d "t" ? ("t", "lib") : "../lib"; use Basic (create_grammar => "gedcom-5.5.grammar", resolve => "unresolve_xrefs", read_only => 0); Gedcom-1.19/t/pod.t0000644000175000017500000000020112204002474012476 0ustar pjcjpjcjuse Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); Gedcom-1.19/t/lines/0000755000175000017500000000000012204002636012650 5ustar pjcjpjcjGedcom-1.19/t/lines/lines.l0000644000175000017500000000001612204002474014134 0ustar pjcjpjcjte"st1 te'st2 Gedcom-1.19/t/lines/bias.l0000644000175000017500000000133112204002474013741 0ustar pjcjpjcjPrevious birth Next record birth MF M F 00 21 16 (excluded from statistics) 01 2 2 10 5 9 11 4 1 20 1 1 21 3 0 31 1 0 41 1 0 Total: 17 13 7 birth combinations found 30 'next' individuals (excluding firstborns) Male excess of previous births= 47% +/- 69% Male excess of next births = 13% +/- 49% Correlation between previous and next = -36% Fraction of births that match (in sex) a run of previous births in the same family. Children of unknown sex ignored in this tabulation. Run Total Matching Length Cases Cases % 1 30 14 46 2 4 3 75 Gedcom-1.19/t/lines/lines0000644000175000017500000000006212204002474013703 0ustar pjcjpjcjproc main () { "te\"st1\n" 'te\'st2' nl() } Gedcom-1.19/t/lines/lines.plx0000644000175000017500000000336712204002474014520 0ustar pjcjpjcj#!/usr/local/bin/perl -w # This program was generated by lines2perl, which is part of Gedcom.pm. # Gedcom.pm is Copyright 1999-2013, Paul Johnson (paul@pjcj.net) # Version 1.19 - 18th August 2013 # 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 use strict; require 5.005; use diagnostics; use integer; use Getopt::Long; use Gedcom::LifeLines 1.19; my $Ged; # Gedcom object my %Opts; # options my $_Traverse_sub; # subroutine for traverse sub out { print STDERR @_ unless $Opts{quiet} } sub outf { printf STDERR @_ unless $Opts{quiet} } sub initialise () { die "usage: $0 -gedcom_file file.ged\n" unless GetOptions(\%Opts, "gedcom_file=s", "quiet!", "validate!", ) and defined $Opts{gedcom_file}; local $SIG{__WARN__} = sub { out "\n@_" }; out "reading..."; $Ged = Gedcom->new ( gedcom_file => $Opts{gedcom_file}, callback => sub { out "." } ); if ($Opts{validate}) { out "\nvalidating..."; my %x; my $vcb = sub { my ($r) = @_; my $t = $r->{xref}; out "." if $t && !$x{$t}++; }; $Ged->validate($vcb); } out "\n"; set_ged($Ged); } $SIG{__WARN__} = sub { out $_[0] unless $_[0] =~ /^Use of uninitialized value/ }; sub main () { display "te\"st1\n"; display 'te\'st2'; display &nl(); undef } initialise(); main(); flush(); 0 __END__ Original LifeLines program follows: proc main () { "te\"st1\n" 'te\'st2' nl() } Gedcom-1.19/t/lines/namefreq.l0000644000175000017500000000345412204002474014631 0ustar pjcjpjcjFrequency of given names (first only) in the database Name Occurrences Henry 4 Alexandra 3 Edward 3 George 3 A2 2 A3B3 2 Alexander 2 David 2 Elizabeth 2 James 2 Margaret 2 Marina 2 Mark 2 Sarah 2 William 2 A3 1 A4B4C4D4 1 Alice 1 Andrew 1 Angela 1 Angus 1 Anne 1 Anthony 1 B1 1 B2 1 Beatrice 1 Benjamin 1 Bessiewallis 1 Birgitte 1 Charles 1 Davina 1 Diana 1 Edward_VII 1 Edward_VIII 1 Elizabeth_II 1 Ellen 1 Emily 1 Eugenie 1 Frederick 1 Fredericka 1 Gabriella 1 George_V 1 George_VI 1 Gerald 1 Helen 1 Jeremy 1 John 1 Julia 1 Julie 1 Katharine 1 Marie-Christine 1 Marion 1 Martin 1 Mary 1 Mary_of_Teck 1 Michael 1 Nicholas 1 Patricia 1 Paul 1 Peter 1 Philip 1 Richard 1 Rose 1 Rowan 1 Sophie 1 Sylvana 1 Thomas 1 Zara 1 a3b3 1 a4b4c4d4 1 Gedcom-1.19/t/lines/namefreq.plx0000644000175000017500000002247512204002474015205 0ustar pjcjpjcj#!/usr/local/bin/perl -w # This program was generated by lines2perl, which is part of Gedcom.pm. # Gedcom.pm is Copyright 1999-2013, Paul Johnson (paul@pjcj.net) # Version 1.19 - 18th August 2013 # 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 use strict; require 5.005; use diagnostics; use integer; use Getopt::Long; use Gedcom::LifeLines 1.19; my $Ged; # Gedcom object my %Opts; # options my $_Traverse_sub; # subroutine for traverse sub out { print STDERR @_ unless $Opts{quiet} } sub outf { printf STDERR @_ unless $Opts{quiet} } sub initialise () { die "usage: $0 -gedcom_file file.ged\n" unless GetOptions(\%Opts, "gedcom_file=s", "quiet!", "validate!", ) and defined $Opts{gedcom_file}; local $SIG{__WARN__} = sub { out "\n@_" }; out "reading..."; $Ged = Gedcom->new ( gedcom_file => $Opts{gedcom_file}, callback => sub { out "." } ); if ($Opts{validate}) { out "\nvalidating..."; my %x; my $vcb = sub { my ($r) = @_; my $t = $r->{xref}; out "." if $t && !$x{$t}++; }; $Ged->validate($vcb); } out "\n"; set_ged($Ged); } $SIG{__WARN__} = sub { out $_[0] unless $_[0] =~ /^Use of uninitialized value/ }; # /* # namefreq # # Tabulate frequency of first names in database. # # Version 1 - 1993 Jun 16 - John F. Chandler # Version 2 - 1993 Jun 18 (sort output by frequency) # Version 3 - 1995 Mar 8 (requires LL 3.0 or higher) # (Uses Jim Eggert's Quicksort routine) # # This report counts occurrences of all first (given) names in the # database. Individuals with only surnames are not counted. If the # surname is listed first, the next word is taken as the given name. # # The output file is normally sorted in order of decreasing frequency, # but the sort order can be altered by changing func "compare", e.g., # comment out the existing "set" and uncomment the one for alphabetical # order. # # This program works only with LifeLines. # # */ my $name_counts; # /* used by comparison in sorting by frequency */ # /* Comparison function for sorting. Same convention as strcmp. */ sub compare ($$) { my($astring, $bstring) = @_; my $ret; # /* alphabetical: # return(strcmp(astring,bstring)) */ # /* decreasing frequency: */ # if ($ret = ($name_counts->{$bstring} - $name_counts->{$astring})) { return ($ret); } return (&strcmp($astring, $bstring)); } # /* # quicksort: Sort an input list by generating a permuted index list # Input: alist - list to be sorted # Output: ilist - list of index pointers into "alist" in sorted order # Needed: compare- external function of two arguments to return -1,0,+1 # according to relative order of the two arguments # */ sub quicksort ($$) { my($alist, $ilist) = @_; my $index; my $len; $len = (scalar @$alist); $index = $len; LOOP: while ($index) { $ilist->[$index - 1] = $index; $index--; } display &qsort($alist, $ilist, 1, $len); undef } # /* recursive core of quicksort */ sub qsort ($$$$) { my($alist, $ilist, $left, $right) = @_; my $mid; my $pcur; my $pivot; if ($pcur = &getpivot($alist, $ilist, $left, $right)) { $pivot = $alist->[$ilist->[$pcur - 1] - 1]; $mid = &partition($alist, $ilist, $left, $right, $pivot); display &qsort($alist, $ilist, $left, ($mid - 1)); display &qsort($alist, $ilist, $mid, $right); } undef } # /* partition around pivot */ sub partition ($$$$$) { my($alist, $ilist, $left, $right, $pivot) = @_; my $ge; my $gt; my $lt; my $tmp; LOOP: while (1) { $tmp = $ilist->[$left - 1]; $ilist->[$left - 1] = $ilist->[$right - 1]; $ilist->[$right - 1] = $tmp; LOOP: while ((&compare($alist->[$ilist->[$left - 1] - 1], $pivot) < 0)) { $left++; } LOOP: while ((&compare($alist->[$ilist->[$right - 1] - 1], $pivot) >= 0)) { $right--; } if (($left > $right)) { last LOOP; } } return ($left); } # /* choose pivot */ sub getpivot ($$$$) { my($alist, $ilist, $left, $right) = @_; my $gt; my $le; my $left0; my $lt; my $pivot; my $rel; $pivot = $alist->[$ilist->[$left - 1] - 1]; $left0 = $left; $left++; LOOP: while (($left <= $right)) { $rel = &compare($alist->[$ilist->[$left - 1] - 1], $pivot); if (($rel > 0)) { return ($left); } if (($rel < 0)) { return ($left0); } $left++; } return (0); } sub main () { my $eq; my $fname; my $gindx; my $ilist; my $index; my $indi; my $namelist; my $names; my $ncomp; my $nmatch; my $not; my $num; my $or; my $sindx; $namelist = []; $name_counts = {}; $names = []; $ilist = []; $num = 0; LOOP: for $indi ($Ged->individuals) { $num++; if ((! ($num % 20))) { display &print("."); } display &extractnames(&inode($indi), $namelist, $ncomp, $sindx); $gindx = 1; if (($sindx == 1)) { $gindx = 2; } $fname = &save($namelist->[$gindx - 1]); if ((($sindx > 1) || ($ncomp > $sindx))) { if ($nmatch = $name_counts->{$fname}) { $nmatch = ($nmatch + 1); } else { push @$names, $fname; $nmatch = 1; } $name_counts->{$fname} = $nmatch; } } display "Frequency of given names (first only) in the database\n\n"; display "Name Occurrences\n\n"; display &quicksort($names, $ilist); $num = 0; LOOP: for $index (@$ilist) { $num++; $fname = $names->[$index - 1]; display $fname; $nmatch = $name_counts->{$fname}; display &col((25 - &strlen(&d($nmatch)))); display &d($nmatch); display "\n"; } undef } initialise(); main(); flush(); 0 __END__ Original LifeLines program follows: /* namefreq Tabulate frequency of first names in database. Version 1 - 1993 Jun 16 - John F. Chandler Version 2 - 1993 Jun 18 (sort output by frequency) Version 3 - 1995 Mar 8 (requires LL 3.0 or higher) (Uses Jim Eggert's Quicksort routine) This report counts occurrences of all first (given) names in the database. Individuals with only surnames are not counted. If the surname is listed first, the next word is taken as the given name. The output file is normally sorted in order of decreasing frequency, but the sort order can be altered by changing func "compare", e.g., comment out the existing "set" and uncomment the one for alphabetical order. This program works only with LifeLines. */ global(name_counts) /* used by comparison in sorting by frequency */ /* Comparison function for sorting. Same convention as strcmp. */ func compare(astring,bstring) { /* alphabetical: return(strcmp(astring,bstring)) */ /* decreasing frequency: */ if(ret,sub(lookup(name_counts,bstring),lookup(name_counts,astring))){ return(ret) } return(strcmp(astring,bstring)) } /* quicksort: Sort an input list by generating a permuted index list Input: alist - list to be sorted Output: ilist - list of index pointers into "alist" in sorted order Needed: compare- external function of two arguments to return -1,0,+1 according to relative order of the two arguments */ proc quicksort(alist,ilist) { set(len,length(alist)) set(index,len) while(index) { setel(ilist,index,index) decr(index) } call qsort(alist,ilist,1,len) } /* recursive core of quicksort */ proc qsort(alist,ilist,left,right) { if(pcur,getpivot(alist,ilist,left,right)) { set(pivot,getel(alist,getel(ilist,pcur))) set(mid,partition(alist,ilist,left,right,pivot)) call qsort(alist,ilist,left,sub(mid,1)) call qsort(alist,ilist,mid,right) } } /* partition around pivot */ func partition(alist,ilist,left,right,pivot) { while(1) { set(tmp,getel(ilist,left)) setel(ilist,left,getel(ilist,right)) setel(ilist,right,tmp) while(lt(compare(getel(alist,getel(ilist,left)),pivot),0)) { incr(left) } while(ge(compare(getel(alist,getel(ilist,right)),pivot),0)) { decr(right) } if(gt(left,right)) { break() } } return(left) } /* choose pivot */ func getpivot(alist,ilist,left,right) { set(pivot,getel(alist,getel(ilist,left))) set(left0,left) incr(left) while(le(left,right)) { set(rel,compare(getel(alist,getel(ilist,left)),pivot)) if (gt(rel,0)) { return(left) } if (lt(rel,0)) { return(left0) } incr(left) } return(0) } proc main () { list(namelist) table(name_counts) list(names) list(ilist) forindi (indi, num) { if(not(mod(num,20))) {print(".")} extractnames(inode(indi), namelist, ncomp, sindx) set(gindx,1) if(eq(sindx,1)) { set(gindx,2) } set(fname, save(getel(namelist, gindx))) if( or( gt(sindx,1), gt(ncomp,sindx))) { if(nmatch, lookup(name_counts, fname)) { set(nmatch, add(nmatch, 1)) } else { enqueue(names, fname) set(nmatch, 1) } insert(name_counts, fname, nmatch) } } "Frequency of given names (first only) in the database\n\n" "Name Occurrences\n\n" call quicksort(names,ilist) forlist(ilist, index, num) { set(fname,getel(names,index)) fname set(nmatch, lookup(name_counts, fname)) col(sub(25, strlen(d(nmatch)))) d(nmatch) "\n" } } Gedcom-1.19/t/lines/bias0000644000175000017500000001666712204002474013531 0ustar pjcjpjcj/* bias Compute sex bias based on previous births Version 1.19 - 18th August 2013 Ever notice that certain families seem to have all boys or all girls? Sometimes five or six in a row of all the same sex? Is this a mere statistical fluctuation, or is something special happening? This program gives statistics for male vs female births. First, it tabulates the number of males and females next born after each possible proportion of previous births in the same family. In particular, it gives the sex tally of first-borns (where the proportion of previous births is 0 males and 0 females), then the tally for second-borns where the first child was a female (0+1), and so on. Any combination that doesn't actually occur in the database is skipped in the report (for example, if no family is found with more than 3 sons, the tallies for 3+0, 3+1, and so on would all show a total of 0 males, and there would be no tallies listed for 4+0, 4+1, and so on). Children of unknown sex are not included in these statistics. The program next prints out the relative excess of male births (typically a positive value) over the nominally expected 50%. For many files, there is a tendency to include incomplete families with only one known child; for this reason, "only" children are excluded from these statistics. Also, the male excess is computed for two different subsets of the children: (A) the set of all children not born last, and (B) the set of all children not born first. For both of these, there is also a measure of the variability of the sex ratio to put the percentages in perspective. In addition, the program prints out the correlation between the sex ratio for children already born into a family and the likelihood of getting a male (or female) as the *next* child. If the sample is unbiased, and if the sex of each child is truly random, this correlation should be 0. It also tallies the fraction of births matching the sex of the previous birth in the same family (again, excluding any children of unknown sex). These results are printed out for a succession of increasingly restricted cases: first, for all births of non-first-borns; then, for births preceded by two-in-a-row of the same sex; then, for three-in-a-row; and so on. Bug: combinations with more than 9 sons or more than 9 daughters are not listed properly. This program works only with LifeLines. */ global(maxcount) /* maximum attained runcount */ global(nextsex) /* sex of next offspring in family */ global(prevsex) /* sex of previous offspring in family */ global(runcount) /* number of offspring so far in family */ /* Square Root function. */ func sqrt(x) { set(sqrtval,0) if(gt(x,0)) { set(sqrtval,1) set(approx,1) set(y,4096) while(le(y,x)) { /* coarse grid */ set(approx,y) set(sqrtval,mul(sqrtval,64)) set(y,mul(y,4096)) } set(y,mul(approx,4)) while(le(y,x)) { /* fine grid */ set(approx,y) set(sqrtval,mul(sqrtval,2)) set(y,mul(y,4)) } set(count,0) while(and(ne(y,sqrtval),lt(count,9))) { set(y,div(x,sqrtval)) set(sqrtval,div(add(y,sqrtval),2)) set(count,add(1,count)) } } return(sqrtval) } proc accstep(list) { set(x,1) while(le(x,runcount)) { setel(list,x,add(1,getel(list,x))) set(x,add(1,x)) } } proc accum(samsex,difsex) { if(gt(runcount,0)) { if(strcmp(nextsex,prevsex)) { call accstep(difsex) set(runcount,0) } else { call accstep(samsex) } } set(prevsex,nextsex) set(runcount,add(1,runcount)) if(gt(runcount,maxcount)) {set(maxcount,runcount)} } proc main () { list(males) list(fems) list(samsex) list(difsex) set(totmales,0) set(totfems,0) set(onlymales,0) set(onlyfems,0) forfam (family, num) { set(count,0) set(runcount,0) children(family,child,fnum) { set(nextsex,sex(child)) if(not(strcmp(nextsex,"M"))) { call accum(samsex,difsex) if(gt(count,0)) { set(totmales,add(1,totmales)) setel(males,count,add(1,getel(males,count))) } else {set(onlymales,add(1,onlymales))} set(count,add(count,10)) } elsif(not(strcmp(nextsex,"F"))) { call accum(samsex,difsex) if(gt(count,0)) { set(totfems,add(1,totfems)) setel(fems,count,add(1,getel(fems,count))) } else {set(onlyfems,add(1,onlyfems))} if(gt(9,mod(count,10))) {set(count,add(count,1))} else { print("More than 9 daughters\n") } } } } /* Initialize statistics */ set(tot,add(totmales,totfems)) set(count,1) set(nsample,0) set(sumnfract,0) set(sumpfract,0) set(sumsqnfract,0) set(sumsqpfract,0) set(prodfract,0) set(nrecs,0) "Previous\nbirth Next\nrecord birth\nMF M F\n" "00" col(sub(13,strlen(d(onlymales)))) d(onlymales) col(sub(20,strlen(d(onlyfems)))) d(onlyfems) " (excluded from statistics)\n\n" while(lt(count,100)) { set(nmales,getel(males,count)) set(nfems,getel(fems,count)) if(or(nmales,nfems)) { set(nrecs,add(1,nrecs)) if(lt(count,10)) { "0" } d(count) col(sub(13,strlen(d(nmales)))) d(nmales) col(sub(20,strlen(d(nfems)))) d(nfems) "\n" set(nsample,add(nsample,1)) set(pboys,div(count,10)) set(pgirls,mod(count,10)) set(weight,add(nmales,nfems)) set(p,add(pboys,pgirls)) /* scales: pf-100, sqpf-10000, nf-100, sqnf-10000, prod-10000 i.e., express fractions as percent This makes integer arithmetic acceptable. Note that pfract is too small, on average, by 0.5, etc. */ set(pfract,div(mul(100,sub(pboys,pgirls)),p)) set(wtpfr,mul(weight,pfract)) set(sumpfract,add(sumpfract,wtpfr)) set(sumsqpfract,add(sumsqpfract,mul(pfract,wtpfr))) set(wtnfr,mul(100,sub(nmales,nfems))) set(nfract,div(wtnfr,weight)) /* set(sumnfract,add(sumnfract,wtnfr)) -- use grand difference */ set(sumsqnfract,add(sumsqnfract,mul(nfract,wtnfr))) set(prodfract,add(prodfract,mul(wtnfr,pfract))) } set(count, add(count,1)) } "Total:" col(sub(13,strlen(d(totmales)))) d(totmales) col(sub(20,strlen(d(totfems)))) d(totfems) "\n" d(nrecs) " birth combinations found\n" d(tot) " 'next' individuals (excluding firstborns)\n\n" /* Make approsimate corrections for roundoff errors */ set(sqcorr,mul(50,sub(totmales,totfems))) set(sumnfract,mul(100,sub(totmales,totfems))) set(sumsqnfract,add(sumsqnfract,sqcorr)) set(procfract,add(prodfract,sqcorr)) set(sumpfract,add(sumpfract,div(tot,2))) set(sumsqpfract,sub(add(sumsqpfract,sumpfract),div(tot,3))) set(sumsqpfract,sub(sumsqpfract,div(mul(sumpfract,sumpfract),tot))) set(sumsqnfract,sub(sumsqnfract,div(mul(sumnfract,sumnfract),tot))) set(prodfract,sub(prodfract,div(mul(sumpfract,sumnfract),tot))) set(rssp,sqrt(sumsqpfract)) set(rssn,sqrt(sumsqnfract)) set(correl,div(mul(div(prodfract,rssp),100),rssn)) set(rmsp,sqrt(div(sumsqpfract,tot))) set(rmsn,sqrt(div(sumsqnfract,tot))) "Male excess of previous births= " d(div(sumpfract,tot)) "% +/- " d(rmsp) "%\n" "Male excess of next births = " d(div(sumnfract,tot)) "% +/- " d(rmsn) "%\n" "Correlation between previous and next = " d(correl) "%\n" set(count,1) "\nFraction of births that match (in sex) a run of previous births in the" "\nsame family. Children of unknown sex ignored in this tabulation.\n" "\nRun" col(sub(13,5)) "Total" col(sub(25,9)) "Matching" "\nLength" col(sub(13,5)) "Cases" col(sub(23,5)) "Cases" col(sub(29,1)) "%\n" while(le(count,maxcount)) { set(samesex,getel(samsex,count)) set(diffsex,getel(difsex,count)) set(allsex,add(diffsex,samesex)) if(gt(allsex,0)) { d(count) col(sub(13,strlen(d(allsex)))) d(allsex) col(sub(23,strlen(d(samesex)))) d(samesex) set(percent,d(div(mul(100,samesex),allsex))) col(sub(29,strlen(percent))) percent "\n" } set(count,add(1,count)) set(birth,"births") } } Gedcom-1.19/t/lines/namefreq0000644000175000017500000000651312204002474014376 0ustar pjcjpjcj/* namefreq Tabulate frequency of first names in database. Version 1 - 1993 Jun 16 - John F. Chandler Version 2 - 1993 Jun 18 (sort output by frequency) Version 3 - 1995 Mar 8 (requires LL 3.0 or higher) (Uses Jim Eggert's Quicksort routine) This report counts occurrences of all first (given) names in the database. Individuals with only surnames are not counted. If the surname is listed first, the next word is taken as the given name. The output file is normally sorted in order of decreasing frequency, but the sort order can be altered by changing func "compare", e.g., comment out the existing "set" and uncomment the one for alphabetical order. This program works only with LifeLines. */ global(name_counts) /* used by comparison in sorting by frequency */ /* Comparison function for sorting. Same convention as strcmp. */ func compare(astring,bstring) { /* alphabetical: return(strcmp(astring,bstring)) */ /* decreasing frequency: */ if(ret,sub(lookup(name_counts,bstring),lookup(name_counts,astring))){ return(ret) } return(strcmp(astring,bstring)) } /* quicksort: Sort an input list by generating a permuted index list Input: alist - list to be sorted Output: ilist - list of index pointers into "alist" in sorted order Needed: compare- external function of two arguments to return -1,0,+1 according to relative order of the two arguments */ proc quicksort(alist,ilist) { set(len,length(alist)) set(index,len) while(index) { setel(ilist,index,index) decr(index) } call qsort(alist,ilist,1,len) } /* recursive core of quicksort */ proc qsort(alist,ilist,left,right) { if(pcur,getpivot(alist,ilist,left,right)) { set(pivot,getel(alist,getel(ilist,pcur))) set(mid,partition(alist,ilist,left,right,pivot)) call qsort(alist,ilist,left,sub(mid,1)) call qsort(alist,ilist,mid,right) } } /* partition around pivot */ func partition(alist,ilist,left,right,pivot) { while(1) { set(tmp,getel(ilist,left)) setel(ilist,left,getel(ilist,right)) setel(ilist,right,tmp) while(lt(compare(getel(alist,getel(ilist,left)),pivot),0)) { incr(left) } while(ge(compare(getel(alist,getel(ilist,right)),pivot),0)) { decr(right) } if(gt(left,right)) { break() } } return(left) } /* choose pivot */ func getpivot(alist,ilist,left,right) { set(pivot,getel(alist,getel(ilist,left))) set(left0,left) incr(left) while(le(left,right)) { set(rel,compare(getel(alist,getel(ilist,left)),pivot)) if (gt(rel,0)) { return(left) } if (lt(rel,0)) { return(left0) } incr(left) } return(0) } proc main () { list(namelist) table(name_counts) list(names) list(ilist) forindi (indi, num) { if(not(mod(num,20))) {print(".")} extractnames(inode(indi), namelist, ncomp, sindx) set(gindx,1) if(eq(sindx,1)) { set(gindx,2) } set(fname, save(getel(namelist, gindx))) if( or( gt(sindx,1), gt(ncomp,sindx))) { if(nmatch, lookup(name_counts, fname)) { set(nmatch, add(nmatch, 1)) } else { enqueue(names, fname) set(nmatch, 1) } insert(name_counts, fname, nmatch) } } "Frequency of given names (first only) in the database\n\n" "Name Occurrences\n\n" call quicksort(names,ilist) forlist(ilist, index, num) { set(fname,getel(names,index)) fname set(nmatch, lookup(name_counts, fname)) col(sub(25, strlen(d(nmatch)))) d(nmatch) "\n" } } Gedcom-1.19/t/lines/bias.plx0000644000175000017500000004607212204002474014324 0ustar pjcjpjcj#!/usr/local/bin/perl -w # This program was generated by lines2perl, which is part of Gedcom.pm. # Gedcom.pm is Copyright 1999-2013, Paul Johnson (paul@pjcj.net) # Version 1.19 - 18th August 2013 # 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 use strict; require 5.005; use diagnostics; use integer; use Getopt::Long; use Gedcom::LifeLines 1.19; my $Ged; # Gedcom object my %Opts; # options my $_Traverse_sub; # subroutine for traverse sub out { print STDERR @_ unless $Opts{quiet} } sub outf { printf STDERR @_ unless $Opts{quiet} } sub initialise () { die "usage: $0 -gedcom_file file.ged\n" unless GetOptions(\%Opts, "gedcom_file=s", "quiet!", "validate!", ) and defined $Opts{gedcom_file}; local $SIG{__WARN__} = sub { out "\n@_" }; out "reading..."; $Ged = Gedcom->new ( gedcom_file => $Opts{gedcom_file}, callback => sub { out "." } ); if ($Opts{validate}) { out "\nvalidating..."; my %x; my $vcb = sub { my ($r) = @_; my $t = $r->{xref}; out "." if $t && !$x{$t}++; }; $Ged->validate($vcb); } out "\n"; set_ged($Ged); } $SIG{__WARN__} = sub { out $_[0] unless $_[0] =~ /^Use of uninitialized value/ }; # /* # bias # # Compute sex bias based on previous births # # Version 1.19 - 18th August 2013 # # Ever notice that certain families seem to have all boys or all girls? # Sometimes five or six in a row of all the same sex? Is this a mere # statistical fluctuation, or is something special happening? # # This program gives statistics for male vs female births. First, it # tabulates the number of males and females next born after each possible # proportion of previous births in the same family. In particular, it # gives the sex tally of first-borns (where the proportion of previous # births is 0 males and 0 females), then the tally for second-borns where # the first child was a female (0+1), and so on. Any combination that # doesn't actually occur in the database is skipped in the report (for # example, if no family is found with more than 3 sons, the tallies for # 3+0, 3+1, and so on would all show a total of 0 males, and there would # be no tallies listed for 4+0, 4+1, and so on). # # Children of unknown sex are not included in these statistics. # # The program next prints out the relative excess of male births # (typically a positive value) over the nominally expected 50%. For many # files, there is a tendency to include incomplete families with only one # known child; for this reason, "only" children are excluded from these # statistics. Also, the male excess is computed for two different subsets # of the children: (A) the set of all children not born last, and (B) the # set of all children not born first. For both of these, there is also a # measure of the variability of the sex ratio to put the percentages in # perspective. In addition, the program prints out the correlation # between the sex ratio for children already born into a family and the # likelihood of getting a male (or female) as the *next* child. If the # sample is unbiased, and if the sex of each child is truly random, this # correlation should be 0. # # It also tallies the fraction of births matching the sex of the previous # birth in the same family (again, excluding any children of unknown sex). # These results are printed out for a succession of increasingly restricted # cases: first, for all births of non-first-borns; then, for births preceded # by two-in-a-row of the same sex; then, for three-in-a-row; and so on. # # Bug: combinations with more than 9 sons or more than 9 daughters are not # listed properly. # # This program works only with LifeLines. # # */ my $maxcount; # /* maximum attained runcount */ my $nextsex; # /* sex of next offspring in family */ my $prevsex; # /* sex of previous offspring in family */ my $runcount; # /* number of offspring so far in family */ # /* Square Root function. */ sub sqrt ($) { my($x) = @_; my $and; my $approx; my $count; my $gt; my $le; my $sqrtval; my $y; $sqrtval = 0; if (($x > 0)) { $sqrtval = 1; $approx = 1; $y = 4096; LOOP: while (($y <= $x)) { # /* coarse grid */ # $approx = $y; $sqrtval = ($sqrtval * 64); $y = ($y * 4096); } $y = ($approx * 4); LOOP: while (($y <= $x)) { # /* fine grid */ # $approx = $y; $sqrtval = ($sqrtval * 2); $y = ($y * 4); } $count = 0; LOOP: while ((($y != $sqrtval) && ($count < 9))) { $y = ($x / $sqrtval); $sqrtval = (($y + $sqrtval) / 2); $count = (1 + $count); } } return ($sqrtval); } sub accstep ($) { my($list) = @_; my $le; my $x; $x = 1; LOOP: while (($x <= $runcount)) { $list->[$x - 1] = (1 + $list->[$x - 1]); $x = (1 + $x); } undef } sub accum ($$) { my($samsex, $difsex) = @_; my $gt; my $strcmp; if (($runcount > 0)) { if (&strcmp($nextsex, $prevsex)) { display &accstep($difsex); $runcount = 0; } else { display &accstep($samsex); } } $prevsex = $nextsex; $runcount = (1 + $runcount); if (($runcount > $maxcount)) { $maxcount = $runcount; } undef } sub main () { my $allsex; my $birth; my $child; my $correl; my $count; my $diffsex; my $difsex; my $family; my $fems; my $fnum; my $gt; my $le; my $lt; my $males; my $nfems; my $nfract; my $nmales; my $not; my $nrecs; my $nsample; my $num; my $onlyfems; my $onlymales; my $or; my $p; my $pboys; my $percent; my $pfract; my $pgirls; my $procfract; my $prodfract; my $rmsn; my $rmsp; my $rssn; my $rssp; my $samesex; my $samsex; my $sqcorr; my $sumnfract; my $sumpfract; my $sumsqnfract; my $sumsqpfract; my $tot; my $totfems; my $totmales; my $weight; my $wtnfr; my $wtpfr; $males = []; $fems = []; $samsex = []; $difsex = []; $totmales = 0; $totfems = 0; $onlymales = 0; $onlyfems = 0; $num = 0; LOOP: for $family ($Ged->families) { $num++; $count = 0; $runcount = 0; $fnum = 0; LOOP: for $child ($family->children) { $fnum++; $nextsex = &sex($child); if ((! &strcmp($nextsex, "M"))) { display &accum($samsex, $difsex); if (($count > 0)) { $totmales = (1 + $totmales); $males->[$count - 1] = (1 + $males->[$count - 1]); } else { $onlymales = (1 + $onlymales); } $count = ($count + 10); } elsif ((! &strcmp($nextsex, "F"))) { display &accum($samsex, $difsex); if (($count > 0)) { $totfems = (1 + $totfems); $fems->[$count - 1] = (1 + $fems->[$count - 1]); } else { $onlyfems = (1 + $onlyfems); } if ((9 > ($count % 10))) { $count = ($count + 1); } else { display &print("More than 9 daughters\n"); } } } } # /* Initialize statistics */ $tot = ($totmales + $totfems); $count = 1; $nsample = 0; $sumnfract = 0; $sumpfract = 0; $sumsqnfract = 0; $sumsqpfract = 0; $prodfract = 0; $nrecs = 0; display "Previous\nbirth Next\nrecord birth\nMF M F\n"; display "00"; display &col((13 - &strlen(&d($onlymales)))); display &d($onlymales); display &col((20 - &strlen(&d($onlyfems)))); display &d($onlyfems); display " (excluded from statistics)\n\n"; LOOP: while (($count < 100)) { $nmales = $males->[$count - 1]; $nfems = $fems->[$count - 1]; if (($nmales || $nfems)) { $nrecs = (1 + $nrecs); if (($count < 10)) { display "0"; } display &d($count); display &col((13 - &strlen(&d($nmales)))); display &d($nmales); display &col((20 - &strlen(&d($nfems)))); display &d($nfems); display "\n"; $nsample = ($nsample + 1); $pboys = ($count / 10); $pgirls = ($count % 10); $weight = ($nmales + $nfems); $p = ($pboys + $pgirls); # /* scales: pf-100, sqpf-10000, nf-100, sqnf-10000, prod-10000 # i.e., express fractions as percent # This makes integer arithmetic acceptable. # Note that pfract is too small, on average, by 0.5, etc. */ # # $pfract = ((100 * ($pboys - $pgirls)) / $p); $wtpfr = ($weight * $pfract); $sumpfract = ($sumpfract + $wtpfr); $sumsqpfract = ($sumsqpfract + ($pfract * $wtpfr)); $wtnfr = (100 * ($nmales - $nfems)); $nfract = ($wtnfr / $weight); # /* set(sumnfract,add(sumnfract,wtnfr)) -- use grand difference */ # $sumsqnfract = ($sumsqnfract + ($nfract * $wtnfr)); $prodfract = ($prodfract + ($wtnfr * $pfract)); } $count = ($count + 1); } display "Total:"; display &col((13 - &strlen(&d($totmales)))); display &d($totmales); display &col((20 - &strlen(&d($totfems)))); display &d($totfems); display "\n"; display &d($nrecs); display " birth combinations found\n"; display &d($tot); display " 'next' individuals (excluding firstborns)\n\n"; # /* Make approsimate corrections for roundoff errors */ $sqcorr = (50 * ($totmales - $totfems)); $sumnfract = (100 * ($totmales - $totfems)); $sumsqnfract = ($sumsqnfract + $sqcorr); $procfract = ($prodfract + $sqcorr); $sumpfract = ($sumpfract + ($tot / 2)); $sumsqpfract = (($sumsqpfract + $sumpfract) - ($tot / 3)); $sumsqpfract = ($sumsqpfract - (($sumpfract * $sumpfract) / $tot)); $sumsqnfract = ($sumsqnfract - (($sumnfract * $sumnfract) / $tot)); $prodfract = ($prodfract - (($sumpfract * $sumnfract) / $tot)); $rssp = &sqrt($sumsqpfract); $rssn = &sqrt($sumsqnfract); $correl = ((($prodfract / $rssp) * 100) / $rssn); $rmsp = &sqrt(($sumsqpfract / $tot)); $rmsn = &sqrt(($sumsqnfract / $tot)); display "Male excess of previous births= "; display &d(($sumpfract / $tot)); display "% +/- "; display &d($rmsp); display "%\n"; display "Male excess of next births = "; display &d(($sumnfract / $tot)); display "% +/- "; display &d($rmsn); display "%\n"; display "Correlation between previous and next = "; display &d($correl); display "%\n"; $count = 1; display "\nFraction of births that match (in sex) a run of previous births in the"; display "\nsame family. Children of unknown sex ignored in this tabulation.\n"; display "\nRun"; display &col((13 - 5)); display "Total"; display &col((25 - 9)); display "Matching"; display "\nLength"; display &col((13 - 5)); display "Cases"; display &col((23 - 5)); display "Cases"; display &col((29 - 1)); display "%\n"; LOOP: while (($count <= $maxcount)) { $samesex = $samsex->[$count - 1]; $diffsex = $difsex->[$count - 1]; $allsex = ($diffsex + $samesex); if (($allsex > 0)) { display &d($count); display &col((13 - &strlen(&d($allsex)))); display &d($allsex); display &col((23 - &strlen(&d($samesex)))); display &d($samesex); $percent = &d(((100 * $samesex) / $allsex)); display &col((29 - &strlen($percent))); display $percent; display "\n"; } $count = (1 + $count); $birth = "births"; } undef } initialise(); main(); flush(); 0 __END__ Original LifeLines program follows: /* bias Compute sex bias based on previous births Version 1.19 - 18th August 2013 Ever notice that certain families seem to have all boys or all girls? Sometimes five or six in a row of all the same sex? Is this a mere statistical fluctuation, or is something special happening? This program gives statistics for male vs female births. First, it tabulates the number of males and females next born after each possible proportion of previous births in the same family. In particular, it gives the sex tally of first-borns (where the proportion of previous births is 0 males and 0 females), then the tally for second-borns where the first child was a female (0+1), and so on. Any combination that doesn't actually occur in the database is skipped in the report (for example, if no family is found with more than 3 sons, the tallies for 3+0, 3+1, and so on would all show a total of 0 males, and there would be no tallies listed for 4+0, 4+1, and so on). Children of unknown sex are not included in these statistics. The program next prints out the relative excess of male births (typically a positive value) over the nominally expected 50%. For many files, there is a tendency to include incomplete families with only one known child; for this reason, "only" children are excluded from these statistics. Also, the male excess is computed for two different subsets of the children: (A) the set of all children not born last, and (B) the set of all children not born first. For both of these, there is also a measure of the variability of the sex ratio to put the percentages in perspective. In addition, the program prints out the correlation between the sex ratio for children already born into a family and the likelihood of getting a male (or female) as the *next* child. If the sample is unbiased, and if the sex of each child is truly random, this correlation should be 0. It also tallies the fraction of births matching the sex of the previous birth in the same family (again, excluding any children of unknown sex). These results are printed out for a succession of increasingly restricted cases: first, for all births of non-first-borns; then, for births preceded by two-in-a-row of the same sex; then, for three-in-a-row; and so on. Bug: combinations with more than 9 sons or more than 9 daughters are not listed properly. This program works only with LifeLines. */ global(maxcount) /* maximum attained runcount */ global(nextsex) /* sex of next offspring in family */ global(prevsex) /* sex of previous offspring in family */ global(runcount) /* number of offspring so far in family */ /* Square Root function. */ func sqrt(x) { set(sqrtval,0) if(gt(x,0)) { set(sqrtval,1) set(approx,1) set(y,4096) while(le(y,x)) { /* coarse grid */ set(approx,y) set(sqrtval,mul(sqrtval,64)) set(y,mul(y,4096)) } set(y,mul(approx,4)) while(le(y,x)) { /* fine grid */ set(approx,y) set(sqrtval,mul(sqrtval,2)) set(y,mul(y,4)) } set(count,0) while(and(ne(y,sqrtval),lt(count,9))) { set(y,div(x,sqrtval)) set(sqrtval,div(add(y,sqrtval),2)) set(count,add(1,count)) } } return(sqrtval) } proc accstep(list) { set(x,1) while(le(x,runcount)) { setel(list,x,add(1,getel(list,x))) set(x,add(1,x)) } } proc accum(samsex,difsex) { if(gt(runcount,0)) { if(strcmp(nextsex,prevsex)) { call accstep(difsex) set(runcount,0) } else { call accstep(samsex) } } set(prevsex,nextsex) set(runcount,add(1,runcount)) if(gt(runcount,maxcount)) {set(maxcount,runcount)} } proc main () { list(males) list(fems) list(samsex) list(difsex) set(totmales,0) set(totfems,0) set(onlymales,0) set(onlyfems,0) forfam (family, num) { set(count,0) set(runcount,0) children(family,child,fnum) { set(nextsex,sex(child)) if(not(strcmp(nextsex,"M"))) { call accum(samsex,difsex) if(gt(count,0)) { set(totmales,add(1,totmales)) setel(males,count,add(1,getel(males,count))) } else {set(onlymales,add(1,onlymales))} set(count,add(count,10)) } elsif(not(strcmp(nextsex,"F"))) { call accum(samsex,difsex) if(gt(count,0)) { set(totfems,add(1,totfems)) setel(fems,count,add(1,getel(fems,count))) } else {set(onlyfems,add(1,onlyfems))} if(gt(9,mod(count,10))) {set(count,add(count,1))} else { print("More than 9 daughters\n") } } } } /* Initialize statistics */ set(tot,add(totmales,totfems)) set(count,1) set(nsample,0) set(sumnfract,0) set(sumpfract,0) set(sumsqnfract,0) set(sumsqpfract,0) set(prodfract,0) set(nrecs,0) "Previous\nbirth Next\nrecord birth\nMF M F\n" "00" col(sub(13,strlen(d(onlymales)))) d(onlymales) col(sub(20,strlen(d(onlyfems)))) d(onlyfems) " (excluded from statistics)\n\n" while(lt(count,100)) { set(nmales,getel(males,count)) set(nfems,getel(fems,count)) if(or(nmales,nfems)) { set(nrecs,add(1,nrecs)) if(lt(count,10)) { "0" } d(count) col(sub(13,strlen(d(nmales)))) d(nmales) col(sub(20,strlen(d(nfems)))) d(nfems) "\n" set(nsample,add(nsample,1)) set(pboys,div(count,10)) set(pgirls,mod(count,10)) set(weight,add(nmales,nfems)) set(p,add(pboys,pgirls)) /* scales: pf-100, sqpf-10000, nf-100, sqnf-10000, prod-10000 i.e., express fractions as percent This makes integer arithmetic acceptable. Note that pfract is too small, on average, by 0.5, etc. */ set(pfract,div(mul(100,sub(pboys,pgirls)),p)) set(wtpfr,mul(weight,pfract)) set(sumpfract,add(sumpfract,wtpfr)) set(sumsqpfract,add(sumsqpfract,mul(pfract,wtpfr))) set(wtnfr,mul(100,sub(nmales,nfems))) set(nfract,div(wtnfr,weight)) /* set(sumnfract,add(sumnfract,wtnfr)) -- use grand difference */ set(sumsqnfract,add(sumsqnfract,mul(nfract,wtnfr))) set(prodfract,add(prodfract,mul(wtnfr,pfract))) } set(count, add(count,1)) } "Total:" col(sub(13,strlen(d(totmales)))) d(totmales) col(sub(20,strlen(d(totfems)))) d(totfems) "\n" d(nrecs) " birth combinations found\n" d(tot) " 'next' individuals (excluding firstborns)\n\n" /* Make approsimate corrections for roundoff errors */ set(sqcorr,mul(50,sub(totmales,totfems))) set(sumnfract,mul(100,sub(totmales,totfems))) set(sumsqnfract,add(sumsqnfract,sqcorr)) set(procfract,add(prodfract,sqcorr)) set(sumpfract,add(sumpfract,div(tot,2))) set(sumsqpfract,sub(add(sumsqpfract,sumpfract),div(tot,3))) set(sumsqpfract,sub(sumsqpfract,div(mul(sumpfract,sumpfract),tot))) set(sumsqnfract,sub(sumsqnfract,div(mul(sumnfract,sumnfract),tot))) set(prodfract,sub(prodfract,div(mul(sumpfract,sumnfract),tot))) set(rssp,sqrt(sumsqpfract)) set(rssn,sqrt(sumsqnfract)) set(correl,div(mul(div(prodfract,rssp),100),rssn)) set(rmsp,sqrt(div(sumsqpfract,tot))) set(rmsn,sqrt(div(sumsqnfract,tot))) "Male excess of previous births= " d(div(sumpfract,tot)) "% +/- " d(rmsp) "%\n" "Male excess of next births = " d(div(sumnfract,tot)) "% +/- " d(rmsn) "%\n" "Correlation between previous and next = " d(correl) "%\n" set(count,1) "\nFraction of births that match (in sex) a run of previous births in the" "\nsame family. Children of unknown sex ignored in this tabulation.\n" "\nRun" col(sub(13,5)) "Total" col(sub(25,9)) "Matching" "\nLength" col(sub(13,5)) "Cases" col(sub(23,5)) "Cases" col(sub(29,1)) "%\n" while(le(count,maxcount)) { set(samesex,getel(samsex,count)) set(diffsex,getel(difsex,count)) set(allsex,add(diffsex,samesex)) if(gt(allsex,0)) { d(count) col(sub(13,strlen(d(allsex)))) d(allsex) col(sub(23,strlen(d(samesex)))) d(samesex) set(percent,d(div(mul(100,samesex),allsex))) col(sub(29,strlen(percent))) percent "\n" } set(count,add(1,count)) set(birth,"births") } } Gedcom-1.19/t/bias.t0000755000175000017500000000143012204002474012642 0ustar pjcjpjcj#!/usr/local/bin/perl -w # Copyright 1999-2013, Paul Johnson (paul@pjcj.net) # 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.19 - 18th August 2013 use strict; use lib -d "t" ? "t" : ".."; use Lines; use File::Spec; my $report = File::Spec->catfile((-d "t" ? ("t/") : ()), "lines", "bias"); Lines->test(tests => 36, report => $report, lines_report => "$report.l", report_command => $ENV{lines} ? "$report.l\n" : undef, generate => $ENV{generate}, perl_program => "$report.plx", perl_report => "$report.p", perl_command => ""); Gedcom-1.19/t/conf/0000755000175000017500000000000012204002636012463 5ustar pjcjpjcjGedcom-1.19/t/conf/gedcom.conf0000644000175000017500000000161112204002474014567 0ustar pjcjpjcj SetHandler perl-script PerlHandler Apache::Status Order Allow,Deny Allow from localhost Allow from .pjcj.net ExtendedStatus On MaxClients 20 MinSpareServers 2 PerlWarn On PerlTaintCheck On PerlPassEnv GEDCOM_TEST $Gedcom::TEST = 1; use Apache::Status; $ENV{PATH} = "/bin:/usr/bin"; delete @ENV{"IFS", "CDPATH", "ENV", "BASH_ENV"}; $Gedcom::DATA = $Gedcom::ROOT; # location of data stored on server use lib "$Gedcom::ROOT/blib/lib"; use Gedcom::WebServices; my $handlers = [ qw ( plain xml json ) ]; eval Gedcom::WebServices::_set_handlers($handlers); # use Apache::PerlSections; print STDERR Apache::PerlSections->dump; PerlTransHandler Gedcom::WebServices::_parse_uri Gedcom-1.19/t/conf/extra.conf.in0000644000175000017500000000046512204002474015067 0ustar pjcjpjcj# Copyright 2005-2013, Paul Johnson (paul@pjcj.net) # This file will be Include-d by @t_conf_file@ UseCanonicalName Off BEGIN { $Gedcom::ROOT = "@top_dir@" } Include "@t_conf@/gedcom.conf" use Devel::Cover qw(-select \.conf$); Gedcom-1.19/t/lines.t0000755000175000017500000000162012204002474013037 0ustar pjcjpjcj#!/usr/local/bin/perl -w # Copyright 1999-2013, Paul Johnson (paul@pjcj.net) # 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.19 - 18th August 2013 # This is really just a test of the lifelines testing mechanism, but it # also serves as a very basic lifelines test. use strict; use lib -d "t" ? "t" : ".."; use Lines; use File::Spec; my $report = File::Spec->catfile((-d "t" ? ("t/") : ()), "lines", "lines"); Lines->test(tests => 10, report => $report, lines_report => "$report.l", report_command => $ENV{lines} ? "$report.l\n" : undef, generate => $ENV{generate}, perl_program => "$report.plx", perl_report => "$report.p", perl_command => ""); Gedcom-1.19/t/ged_create.t0000755000175000017500000000746112204002474014020 0ustar pjcjpjcjuse strict; use warnings; use Test::More tests => 126; use Gedcom; { my $gedcom_file = "gedcompm.ged"; my $ged = Gedcom->new; isa_ok( $ged, 'Gedcom' ); ok my $i1 = $ged->add_individual("O5"); ok $i1->add("name", "Fred /Bloggs/"); ok $i1->add("birth date", "20 Dec 1775"); ok $i1->add("birth", ["date", 2], "21 Dec 1775"); ok $i1->add(["birth", 2], "date", "22 Dec 1775"); ok $i1->add("sex", "M"); ok my $ix = $ged->add_individual("O"); ok $ix->add("name", "John /Smith/"); ok $ix->add("christening date", "15 July 1954"); ok $ix->add("christening date", "25 July 1954"); ok $ix->add("sex", "F"); ok my $i2 = $ged->add_individual; ok $i2->add("name", "Betty /Bloggs/"); ok $i2->add("christening date", "11 May 1777"); ok $i2->add("sex", "F"); ok my $i3 = $ged->add_individual; ok $i3->add("name", "Jane /Bloggs/"); ok my $i4 = $ged->add_individual; ok $i4->add("name", "Joe /Bloggs/"); ok $i4->add("birth date", "2 Feb 1802"); ok $i4->set("birth date", "3 Feb 1802"); ok $i4->add("sex", "M"); ok my $f1 = $ged->add_family; ok $f1->add_husband($i1); ok $f1->add_wife($i2); ok $f1->add_child($i3); ok $f1->add_child($i4); ok my $n1 = $ged->add_note("First line"); ok $n1->add("cont", "This is a note."); ok $n1->add("cont", "Please take notice."); ok $n1->add("conc", "There's more. O"); ok $n1->add("conc", "k, that's it."); ok my $n2 = $ged->add_note({ xref => "N100" }, "Note 2"); ok $i4->add("note", "This is a note on one line"); ok $i4->add("note", $n2); ok $i2->delete; ok my $i5 = $ged->add_individual; ok $i5->add("name", "Susan /Bloggs/"); ok $i5->add("christening date", "11 May 1778"); ok $i5->add("sex", "F"); my $obj1 = $i5->add("OBJE", 12); my $obj2 = $i5->add("OBJE"); $obj2->add("FORM", "qqq"); $obj2->add("FILE", "rrr"); ok $f1->add_wife($i5); ok $f1->delete; ok $ged->renumber; ok $ged->order; $ged->write($gedcom_file); { my $w = 0; local $SIG{ __WARN__ } = sub { $w++ }; ok !$ged->validate, 'Gedcom file is not valid'; is $w, 2, '2 warnings thrown'; } ok -e $gedcom_file, "$gedcom_file exists"; # check the gedcom file is correct ok open F1, $gedcom_file; my @ged_data = ; for (@ged_data) { my $f = ; is $f, $_, "line $. matches" unless m{Ignore}; } ok eof, 'No more lines to compare'; ok close F1; ok unlink $gedcom_file; } __DATA__ 0 HEAD 1 SOUR Gedcom.pm 2 NAME Gedcom.pm 2 VERS Ignore 2 CORP Paul Johnson 3 ADDR http://www.pjcj.net 2 DATA 3 COPR Copyright 1998-2013, Paul Johnson (paul@pjcj.net) 1 NOTE 2 CONT This output was generated by Gedcom.pm. 2 CONT Gedcom.pm is Copyright 1999-2013, Paul Johnson (paul@pjcj.net) 2 CONT Version 1.19 - 18th August 2013 2 CONT 2 CONT Gedcom.pm is free. It is licensed under the same terms as Perl itself. 2 CONT 2 CONT The latest version of Gedcom.pm should be available from my homepage: 2 CONT http://www.pjcj.net 1 GEDC 2 VERS 5.5 2 FORM LINEAGE-LINKED 1 DATE Ignore 1 CHAR ANSEL 1 SUBM @SUBM1@ 0 @SUBM1@ SUBM 1 NAME Ignore 0 @I1@ INDI 1 NAME Fred /Bloggs/ 1 BIRT 2 DATE 20 Dec 1775 2 DATE 21 Dec 1775 1 BIRT 2 DATE 22 Dec 1775 1 SEX M 1 FAMS F1 0 @I2@ INDI 1 NAME John /Smith/ 1 CHR 2 DATE 15 July 1954 2 DATE 25 July 1954 1 SEX F 0 @I3@ INDI 1 NAME Jane /Bloggs/ 1 FAMC F1 0 @I4@ INDI 1 NAME Joe /Bloggs/ 1 BIRT 2 DATE 3 Feb 1802 1 SEX M 1 FAMC F1 1 NOTE This is a note on one line 1 NOTE @N2@ 0 @I5@ INDI 1 NAME Susan /Bloggs/ 1 CHR 2 DATE 11 May 1778 1 SEX F 1 OBJE 12 1 OBJE 2 FORM qqq 2 FILE rrr 1 FAMS F1 0 @N1@ NOTE First line 1 CONT This is a note. 1 CONT Please take notice. 1 CONC There's more. O 1 CONC k, that's it. 0 @N2@ NOTE Note 2 0 TRLR Gedcom-1.19/t/Basic.pm0000644000175000017500000010067012204002474013121 0ustar pjcjpjcj#!/usr/local/bin/perl -w # Copyright 1999-2013, Paul Johnson (paul@pjcj.net) # 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.19 - 18th August 2013 use strict; require 5.005; package Basic; use vars qw($VERSION); $VERSION = "1.19"; use Test (); use Gedcom 1.19; eval "use Date::Manip"; Date_Init("DateFormat=UK") if $INC{"Date/Manip.pm"}; sub ok { my @a = @_; s/[\r\n]+$/\n/ for @a; &Test::ok(@a) } my @Ged_data = ; sub xrefs (@) { join " ", map { $_->xref =~ /(\d+)/; $1 } @_ } sub rins (@) { join " ", map { $_->rin } @_ } sub i (@) { "@_" } sub import { my $class = shift; my %args = @_; my $basic_test = sub { my $ged = shift; my %args = @_; my $resolve = $args{resolve}; my $gedcom_file = $args{gedcom_file}; ok $ged; ok $ged->validate; $ged->$resolve(); ok $ged->validate; $ged->normalise_dates if $INC{"Date/Manip.pm"}; ok $ged->validate; my $fams = 47; my $inds = 91; my %xrefs; ok xrefs($ged->individuals), i(1 .. $inds); ok rins ($ged->individuals), i(2 .. $inds + 1); ok xrefs($ged->families ), i(1 .. $fams); ok rins ($ged->families ), i($inds + 2 .. $fams + $inds + 1); %xrefs = $ged->renumber; ok $ged->validate; $ged->$resolve(); ok $ged->validate; ok $xrefs{INDI}, 91; ok $xrefs{FAM}, 47; ok $xrefs{SUBM}, 1; $ged->order; ok $ged->validate; ok xrefs($ged->individuals), i(1 .. $inds); ok rins ($ged->individuals), join(" ", qw(2 3 4 5 6 8 29 55 63 82 7 9 10 25 11 12 16 20 24 13 14 15 17 18 19 21 22 23 26 27 28 30 31 49 32 47 33 39 43 48 34 35 36 37 38 40 41 42 44 45 46 50 53 51 54 52 56 57 58 59 60 61 62 64 65 71 78 66 67 69 70 68 72 73 75 74 76 77 79 80 81 83 84 85 86 87 88 89 90 91 92)); ok xrefs($ged->families ), i(1 .. $fams); ok rins ($ged->families ), join(" ", qw(94 93 116 95 111 104 106 107 115 96 112 98 108 100 118 99 132 113 114 97 136 102 119 121 139 126 127 128 138 120 122 130 103 125 105 101 117 110 129 133 134 135 109 137 131 123 124)); ok $ged->next_xref("I"), "I" . ($inds + 1); ok $ged->next_xref("F"), "F" . ($fams + 1); ok $ged->next_xref("S"), "S2"; ok my $i31 = $ged->get_individual("Marion Stein"); ok my $famc = $i31->famc; ok my $src = $famc->source; $src = $ged->get_source($src) unless ref $src; ok $src->text, "Source text"; my ($ind) = $ged->get_individual("Elizabeth II"); ok $ind; my %rin_relations = ( ancestors => "8 9 4 5 2 3", brothers => "", children => "12 16 20 24", daughters => "16", descendents => "12 16 20 24 14 15 18 19 22 23", father => "8", husband => "11", mother => "9", parents => "8 9", siblings => "25", sisters => "25", sons => "12 20 24", spouse => "11", wife => "", ); ok rins($ind->$_()), $rin_relations{$_} for sort keys %rin_relations; my %xref1_relations = ( ancestors => "6 12 3 4 1 2", brothers => "", children => "16 17 18 19", daughters => "17", descendents => "16 17 18 19 21 22 24 25 27 28", father => "6", husband => "15", mother => "12", parents => "6 12", siblings => "14", sisters => "14", sons => "16 18 19", spouse => "15", wife => "", ); ok xrefs($ind->$_()), $xref1_relations{$_} for sort keys %xref1_relations; my $ind_xref = $ind->{xref}; ok $ind_xref, "I13"; ok rins($ged->resolve_xref($ind_xref)), "10"; %xrefs = $ged->renumber(xrefs => [$ind_xref]); ok $ged->validate; $ged->$resolve(); ok $ged->validate; ok $xrefs{INDI}, 91; ok $xrefs{FAM}, 47; ok $xrefs{SUBM}, 1; ok rins($ged->resolve_xref($ind_xref)), "17"; ok xrefs($ged->individuals), join(" ", qw(29 30 19 20 21 7 22 23 24 25 31 8 1 9 2 3 4 5 6 10 11 12 13 14 15 16 17 18 26 27 28 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91)); ok rins ($ged->individuals), join(" ", qw(2 3 4 5 6 8 29 55 63 82 7 9 10 25 11 12 16 20 24 13 14 15 17 18 19 21 22 23 26 27 28 30 31 49 32 47 33 39 43 48 34 35 36 37 38 40 41 42 44 45 46 50 53 51 54 52 56 57 58 59 60 61 62 64 65 71 78 66 67 69 70 68 72 73 75 74 76 77 79 80 81 83 84 85 86 87 88 89 90 91 92)); ok xrefs($ged->families), join(" ", qw(14 46 47 10 15 16 17 18 19 2 11 1 3 4 5 6 7 8 9 12 13 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45)); ok rins ($ged->families), join(" ", qw(94 93 116 95 111 104 106 107 115 96 112 98 108 100 118 99 132 113 114 97 136 102 119 121 139 126 127 128 138 120 122 130 103 125 105 101 117 110 129 133 134 135 109 137 131 123 124)); ok $ged->next_xref("I"), "I" . ($inds + 1); ok $ged->next_xref("F"), "F" . ($fams + 1); ok $ged->next_xref("S"), "S2"; ok rins($ind->$_()), $rin_relations{$_} for sort keys %rin_relations; my %xref2_relations = ( ancestors => "7 8 19 20 29 30", brothers => "", children => "3 4 5 6", daughters => "4", descendents => "3 4 5 6 11 12 14 15 17 18", father => "7", husband => "2", mother => "8", parents => "7 8", siblings => "9", sisters => "9", sons => "3 5 6", spouse => "2", wife => "", ); ok xrefs($ind->$_()), $xref2_relations{$_} for sort keys %xref2_relations; my %individuals = ( "B1 C1" => [ 82 ], # exact match "B2 C2" => [ 83, 84, 85 ], # use word boundaries "B3 C3" => [ 86, 87, 88, 89 ], # match anywhere "B3 c3" => [ 86, 87, 88, 89 ], # match anywhere, any case "B4 C4" => [ 90, 91 ], # match in any order "B4 c4" => [ 90, 91 ], # match in any order, any case (order correct) "c4 B4" => [ 90, 91 ], # match in any order, any case (order reversed) ); ok xrefs($ged->get_individual($_)), i(@{$individuals{$_}}) for sort keys %individuals; my $i = $ged->get_individual("I82"); ok $i->note, "Line 1\nLine 2\nLine 3\nLine 4"; ok scalar $i->get_value("birth age"), 0; $i = $ged->get_individual("I83"); my $n = $i->resolve($i->note)->full_value; ok $n, "Line 1\nLine 2"; ok $ged->validate; my $f1 = $gedcom_file . $$; $ged->write($f1); ok $ged->validate; ok -e $f1; # check the gedcom file is correct ok open F1, $f1; ok scalar , $_ for @Ged_data; ok eof; ok close F1; ok unlink $f1; }; my $tests = 1501; my $grammar; if ($grammar = delete $args{create_grammar}) { Test::plan tests => $tests + 3; system ($^X, ((-d "t") ? "." : "..") . "/parse_grammar", $grammar, 0.1); ok $?, 0; ok -e "lib/Gedcom/Grammar_0_1.pm"; $args{grammar_version} = 0.1; } else { Test::plan tests => $tests; } my $g = _new_gedcom( \%args ); $basic_test->( $g, %args ); if ($grammar) { ok unlink ((-d "t") ? "." : "..") . "/lib/Gedcom/Grammar_0_1.pm"; } } sub _new_gedcom { my $args = shift; $args->{gedcom_file} = (-d "t" ? "" : "../") . "royal.ged" unless defined $args->{gedcom_file}; $args->{read_only} = 1 unless defined $args->{read_only}; my $ged = Gedcom->new(%$args); return $ged; } __DATA__ 0 HEAD 1 SOUR PAF 2.2 2 VERS 2.2 1 DEST PAF 1 DATE Friday, 20th November 1992 1 FILE ROYALS.GED 1 CHAR ANSEL 1 GEDC 2 VERS 5.5 2 FORM LINEAGE-LINKED 1 SUBM @SUBM1@ 1 NOTE This Gedcom file should only be used as part of the testsuite 2 CONC for Gedcom.pm (http://www.pjcj.net). I have removed a 2 CONC lot of data from the original, and changed a few bits, so you 2 CONC should use the original if you want royal genealogy. Contact me 2 CONC if you cannot locate the original. 2 CONC 2 CONC Paul Johnson (paul@pjcj.net) 2 CONC 2 CONC >> In a message to Cliff Manis (cmanis@csoftec.csf.com) 2 CONC >> Denis Reid wrote the following: 2 CONC >> Date: Fri, 25 Dec 92 14:12:32 -0500 2 CONC >> From: ah189@cleveland.Freenet.Edu (Denis Reid) 2 CONC >> Subject: THE ROYALS 2 CONC >> First of all, MERRY CHRISTMAS! 2 CONC >> 2 CONC >> You may make this Royal GEDCOM available available to whomever. 2 CONC >> As you know this is a work in process and have received 2 CONC >> suggestions, corrections and additions from all over the planet... 2 CONC >> some even who claim to be descended from Charlemange, himself! 2 CONC >> 2 CONC >> The weakest part of the Royals is in the French and Spanish lines. 2 CONC >> I found that many of the French Kings had multiple mistresses 2 CONC >> whose descendants claimed noble titles, and the Throne itself in 2 CONC >> some cases. I have had the hardest time finding good published 2 CONC >> sources for French and Spanish Royalty. 2 CONC >> 2 CONC >> If you do post it to a BBS or send it around, I would appreciate 2 CONC >> it if you'd append a message to the effect that I would welcome 2 CONC >> comments and suggestions and possible sources to improve the 2 CONC >> database. 2 CONC >> 2 CONC >> Since the Royals had so many names and many titles it was 2 CONC >> difficult to "fill in the blanks" with their name. In the 2 CONC >> previous version, I included all their titles, names, monikers in 2 CONC >> the notes. 2 CONC >> 2 CONC >> Thanks for your interest. Denis Reid 0 @SUBM1@ SUBM 1 NAME Denis R. Reid 1 ADDR 149 Kimrose Lane 2 CONT Broadview Heights, Ohio 44147-1258 2 CONT Internet Email address: ah189@cleveland.freenet.edu 1 PHON (216) 237-5364 1 RIN 1 0 @I29@ INDI 1 NAME Edward_VII /Wettin/ 1 TITL King of England 1 SEX M 1 BIRT 2 DATE Tuesday, 9th November 1841 2 PLAC Buckingham,Palace,London,England 1 DEAT 2 DATE Friday, 6th May 1910 2 PLAC Buckingham,Palace,London,England 1 BURI 2 DATE Friday, 20th May 1910 2 PLAC Windsor,Berkshire,England 1 FAMS @F14@ 1 FAMC @F46@ 1 RIN 2 0 @I30@ INDI 1 NAME Alexandra of_Denmark "Alix"// 1 TITL Princess 1 SEX F 1 BIRT 2 DATE Sunday, 1st December 1844 2 PLAC Yellow Palace,Copenhagen,Denmark 1 DEAT 2 DATE Friday, 20th November 1925 2 PLAC Sandringham,,Norfolk,England 1 BURI 2 PLAC St. George Chap.,Windsor,Berkshire,England 1 FAMS @F14@ 1 FAMC @F47@ 1 RIN 3 0 @I19@ INDI 1 NAME George_V /Windsor/ 1 TITL King of England 1 SEX M 1 BIRT 2 DATE Saturday, 3rd June 1865 2 PLAC Marlborough Hse,London,England 1 CHR 2 DATE Friday, 7th July 1865 1 DEAT 2 DATE Monday, 20th January 1936 2 PLAC Sandringham,Norfolk,England 1 BURI 2 DATE Tuesday, 28th January 1936 2 PLAC Windsor Castle,St. George Chap.,Berkshire,England 1 FAMS @F10@ 1 FAMC @F14@ 1 RIN 4 0 @I20@ INDI 1 NAME Mary_of_Teck (May) // 1 TITL Queen 1 SEX F 1 BIRT 2 DATE Sunday, 26th May 1867 2 PLAC Kensington,Palace,London,England 1 DEAT 2 DATE Tuesday, 24th March 1953 2 PLAC Marlborough Hse,London,England 1 BURI 2 DATE Tuesday, 31st March 1953 2 PLAC St. George's,Chapel,Windsor Castle,England 1 FAMS @F10@ 1 FAMC @F15@ 1 RIN 5 0 @I21@ INDI 1 NAME Edward_VIII /Windsor/ 1 TITL Duke of Windsor 1 SEX M 1 BIRT 2 DATE Saturday, 23rd June 1894 2 PLAC White Lodge,Richmond Park,Surrey,England 1 DEAT 2 DATE Sunday, 28th May 1972 2 PLAC Paris,,,France 1 BURI 2 PLAC Frogmore,Windsor,Berkshire,England 1 FAMS @F16@ 1 FAMC @F10@ 1 RIN 6 0 @I7@ INDI 1 NAME George_VI /Windsor/ 1 TITL King of England 1 SEX M 1 BIRT 2 DATE Saturday, 14th December 1895 2 PLAC York Cottage,Sandringham,Norfolk,England 1 DEAT 2 DATE Wednesday, 6th February 1952 2 PLAC Sandringham,Norfolk,England 1 BURI 2 DATE Tuesday, 11th March 1952 2 PLAC St. George Chap.,,Windsor,England 1 FAMS @F2@ 1 FAMC @F10@ 1 RIN 8 0 @I22@ INDI 1 NAME Mary /Windsor/ 1 TITL Princess Royal 1 SEX F 1 BIRT 2 DATE Sunday, 25th April 1897 2 PLAC York Cottage,Sandringham,Norfolk,England 1 DEAT 2 DATE Sunday, 28th March 1965 2 PLAC Harewood House,Yorkshire,,England 1 FAMS @F20@ 1 FAMC @F10@ 1 RIN 29 0 @I23@ INDI 1 NAME Henry William Frederick/Windsor/ 1 TITL Duke 1 SEX M 1 BIRT 2 DATE Saturday, 31st March 1900 2 PLAC York Cottage,Sandringham,Norfolk,England 1 DEAT 2 DATE 1974 1 FAMS @F31@ 1 FAMC @F10@ 1 RIN 55 0 @I24@ INDI 1 NAME George Edward Alexander/Windsor/ 1 TITL Duke of Kent 1 SEX M 1 BIRT 2 DATE Saturday, 20th December 1902 2 PLAC York Cottage,Sandringham,Norfolk,England 1 DEAT 2 DATE Tuesday, 25th August 1942 2 PLAC Morven,,,Scotland 1 FAMS @F34@ 1 FAMC @F10@ 1 RIN 63 0 @I25@ INDI 1 NAME John Charles Francis/Windsor/ 1 TITL Prince 1 SEX M 1 BIRT 2 DATE Wednesday, 12th July 1905 2 PLAC York Cottage,Sandringham,Norfolk,England 1 DEAT 2 DATE Saturday, 18th January 1919 2 PLAC Wood Farm,Wolferton,Norfolk,England 1 BURI 2 PLAC Sandringham,Norfolk,,England 1 FAMC @F10@ 1 RIN 82 0 @I31@ INDI 1 NAME Bessiewallis /Warfield/ 1 SEX F 1 BIRT 2 DATE 1896 2 PLAC ,,,U.S.A. 1 DEAT 2 DATE Thursday, 24th April 1986 2 PLAC Paris,,,France 1 BURI 2 PLAC Frogmore,Windsor,Berkshire,England 1 FAMS @F16@ 1 FAMS @F17@ 1 FAMS @F18@ 1 FAMC @F19@ 1 RIN 7 0 @I8@ INDI 1 NAME Elizabeth Angela Marguerite/Bowes-Lyon/ 1 TITL Lady 1 SEX F 1 BIRT 2 DATE Saturday, 4th August 1900 2 PLAC ,,London,England 1 CHR 2 DATE Sunday, 23rd September 1900 1 FAMS @F2@ 1 FAMC @F11@ 1 RIN 9 0 @I1@ INDI 1 NAME Elizabeth_II Alexandra Mary/Windsor/ 1 TITL Queen of England 1 SEX F 1 BIRT 2 DATE Wednesday, 21st April 1926 2 PLAC 17 Bruton St.,London,W1,England 1 FAMS @F1@ 1 FAMC @F2@ 1 RIN 10 0 @I9@ INDI 1 NAME Margaret Rose /Windsor/ 1 TITL Princess 1 SEX F 1 BIRT 2 DATE Thursday, 21st August 1930 2 PLAC Glamis Castle,,Angus,Scotland 1 FAMS @F12@ 1 FAMC @F2@ 1 RIN 25 0 @I2@ INDI 1 NAME Philip /Mountbatten/ 1 TITL Prince 1 SEX M 1 BIRT 2 DATE Friday, 10th June 1921 2 PLAC Isle of Kerkira,Mon Repos,Corfu,Greece 1 FAMS @F1@ 1 FAMC @F3@ 1 RIN 11 0 @I3@ INDI 1 NAME Charles Philip Arthur/Windsor/ 1 TITL Prince 1 SEX M 1 BIRT 2 DATE Sunday, 14th November 1948 2 PLAC Buckingham,Palace,London,England 1 CHR 2 DATE Wednesday, 15th December 1948 2 PLAC Buckingham,Palace,Music Room,England 1 FAMS @F4@ 1 FAMC @F1@ 1 RIN 12 0 @I4@ INDI 1 NAME Anne Elizabeth Alice/Windsor/ 1 TITL Princess 1 SEX F 1 BIRT 2 DATE Tuesday, 15th August 1950 2 PLAC Clarence House,St. James,,England 1 CHR 2 DATE Saturday, 21st October 1950 2 PLAC ,,,England 1 FAMS @F6@ 1 FAMC @F1@ 1 RIN 16 0 @I5@ INDI 1 NAME Andrew Albert Christian/Windsor/ 1 TITL Duke of York 1 SEX M 1 BIRT 2 DATE Friday, 19th February 1960 2 PLAC Belgian Suite,Buckingham,Palace,England 1 FAMS @F8@ 1 FAMC @F1@ 1 RIN 20 0 @I6@ INDI 1 NAME Edward Anthony Richard/Windsor/ 1 TITL Prince 1 SEX M 1 BIRT 2 DATE Tuesday, 10th March 1964 2 PLAC Buckingham,Palace,London,England 1 CHR 2 DATE Saturday, 2nd May 1964 1 FAMC @F1@ 1 RIN 24 0 @I10@ INDI 1 NAME Diana Frances /Spencer/ 1 TITL Lady 1 SEX F 1 BIRT 2 DATE Saturday, 1st July 1961 2 PLAC Park House,Sandringham,Norfolk,England 1 CHR 2 PLAC Sandringham,Church,Norfolk,England 1 FAMS @F4@ 1 FAMC @F5@ 1 RIN 13 0 @I11@ INDI 1 NAME William Arthur Philip/Windsor/ 1 TITL Prince 1 SEX M 1 BIRT 2 DATE Monday, 21st June 1982 2 PLAC St. Mary's Hosp.,Paddington,London,England 1 CHR 2 DATE Wednesday, 4th August 1982 2 PLAC Music Room,Buckingham,Palace,England 1 FAMC @F4@ 1 RIN 14 0 @I12@ INDI 1 NAME Henry Charles Albert/Windsor/ 1 TITL Prince 1 SEX M 1 BIRT 2 DATE Saturday, 15th September 1984 2 PLAC St. Mary's Hosp.,Paddington,London,England 1 FAMC @F4@ 1 RIN 15 0 @I13@ INDI 1 NAME Mark Anthony Peter/Phillips/ 1 TITL Captain 1 SEX M 1 BIRT 2 DATE Wednesday, 22nd September 1948 1 FAMS @F6@ 1 FAMC @F7@ 1 RIN 17 0 @I14@ INDI 1 NAME Peter Mark Andrew/Phillips/ 1 SEX M 1 BIRT 2 DATE Tuesday, 15th November 1977 2 PLAC St. Mary's Hosp.,Paddington,London,England 1 CHR 2 DATE Thursday, 22nd December 1977 2 PLAC Music Room,Buckingham,Palace,England 1 FAMC @F6@ 1 RIN 18 0 @I15@ INDI 1 NAME Zara Anne Elizabeth/Phillips/ 1 SEX F 1 BIRT 2 DATE Friday, 15th May 1981 2 PLAC St. Marys Hosp.,Paddington,London,England 1 FAMC @F6@ 1 RIN 19 0 @I16@ INDI 1 NAME Sarah Margaret /Ferguson/ 1 TITL Duchess of York 1 SEX F 1 BIRT 2 DATE Thursday, 15th October 1959 2 PLAC 27 Welbech St.,Marylebone,London,England 1 FAMS @F8@ 1 FAMC @F9@ 1 RIN 21 0 @I17@ INDI 1 NAME Beatrice Elizabeth Mary/Windsor/ 1 TITL Princess 1 SEX F 1 BIRT 2 DATE Monday, 8th August 1988 2 PLAC Portland Hosp.,,England 1 FAMC @F8@ 1 RIN 22 0 @I18@ INDI 1 NAME Eugenie Victoria Helena/Windsor/ 1 TITL Princess 1 SEX F 1 BIRT 2 DATE Friday, 23rd March 1990 2 PLAC London,England 1 CHR 2 DATE Sunday, 23rd December 1990 2 PLAC Sandringham,England 1 FAMC @F8@ 1 RIN 23 0 @I26@ INDI 1 NAME Anthony Charles Robert/Armstrong-Jones/ 1 TITL Earl of Snowdon 1 SEX M 1 BIRT 2 DATE Friday, 7th March 1930 1 FAMS @F12@ 1 FAMS @F13@ 1 RIN 26 0 @I27@ INDI 1 NAME David Albert Charles/Armstrong-Jones/ 1 TITL Vicount Linley 1 SEX M 1 BIRT 2 DATE Friday, 3rd November 1961 1 FAMC @F12@ 1 RIN 27 0 @I28@ INDI 1 NAME Sarah Frances Elizabeth/Armstrong-Jones/ 1 TITL Lady 1 SEX F 1 BIRT 2 DATE Friday, 1st May 1964 1 FAMC @F12@ 1 RIN 28 0 @I32@ INDI 1 NAME Henry George Charles/Lascelles/ 1 TITL Viscount 1 SEX M 1 BIRT 2 DATE 1882 1 DEAT 2 DATE 1947 1 FAMS @F20@ 1 RIN 30 0 @I33@ INDI 1 NAME George Earl_of_Harewood /Lascelles/ 1 TITL Viscount 1 SEX M 1 BIRT 2 DATE 1923 1 FAMS @F21@ 1 FAMS @F22@ 1 FAMC @F20@ 1 RIN 31 0 @I34@ INDI 1 NAME Gerald /Lascelles/ 1 TITL Hon. 1 SEX M 1 BIRT 2 DATE 1924 1 FAMS @F28@ 1 FAMS @F29@ 1 FAMC @F20@ 1 RIN 49 0 @I35@ INDI 1 NAME Marion (Maria) Donata/Stein/ 1 TITL Countess 1 SEX F 1 BIRT 2 DATE 1926 1 FAMS @F21@ 1 FAMC @F23@ 1 RIN 32 0 @I36@ INDI 1 NAME Patricia /Tuckwell/ 1 SEX F 1 BIRT 2 DATE 1923 1 FAMS @F22@ 1 FAMS @F27@ 1 RIN 47 0 @I37@ INDI 1 NAME David /Lascelles/ 1 TITL Viscount 1 SEX M 1 BIRT 2 DATE 1950 1 FAMS @F24@ 1 FAMC @F21@ 1 RIN 33 0 @I38@ INDI 1 NAME James /Lascelles/ 1 TITL Hon. 1 SEX M 1 BIRT 2 DATE 1953 1 FAMS @F25@ 1 FAMC @F21@ 1 RIN 39 0 @I39@ INDI 1 NAME Jeremy /Lascelles/ 1 TITL Hon. 1 SEX M 1 BIRT 2 DATE 1955 1 FAMS @F26@ 1 FAMC @F21@ 1 RIN 43 0 @I40@ INDI 1 NAME Mark /Lascelles/ 1 TITL Hon. 1 SEX M 1 BIRT 2 DATE 1964 1 FAMC @F22@ 1 RIN 48 0 @I41@ INDI 1 NAME Margaret /Messenger/ 1 SEX F 1 FAMS @F24@ 1 RIN 34 0 @I42@ INDI 1 NAME Emily // 1 TITL Hon. 1 SEX F 1 BIRT 2 DATE 1976 1 FAMC @F24@ 1 RIN 35 0 @I43@ INDI 1 NAME Benjamin // 1 TITL Hon. 1 SEX M 1 BIRT 2 DATE 1978 1 FAMC @F24@ 1 RIN 36 0 @I44@ INDI 1 NAME Alexander /Lascelles/ 1 TITL Hon. 1 SEX M 1 BIRT 2 DATE 1980 1 FAMC @F24@ 1 RIN 37 0 @I45@ INDI 1 NAME Edward /Lascelles/ 1 SEX M 1 BIRT 2 DATE 1982 1 FAMC @F24@ 1 RIN 38 0 @I46@ INDI 1 NAME Fredericka Ann /Duhrrson/ 1 SEX F 1 FAMS @F25@ 1 RIN 40 0 @I47@ INDI 1 NAME Sophie /Lascelles/ 1 SEX F 1 BIRT 2 DATE 1973 1 FAMC @F25@ 1 RIN 41 0 @I48@ INDI 1 NAME Rowan /Lascelles/ 1 SEX M 1 BIRT 2 DATE 1977 1 FAMC @F25@ 1 RIN 42 0 @I49@ INDI 1 NAME Julie /Bayliss/ 1 SEX F 1 FAMS @F26@ 1 RIN 44 0 @I50@ INDI 1 NAME Thomas /Lascelles/ 1 SEX M 1 BIRT 2 DATE 1982 1 FAMC @F26@ 1 RIN 45 0 @I51@ INDI 1 NAME Ellen /Lascelles/ 1 SEX F 1 BIRT 2 DATE 1984 1 FAMC @F26@ 1 RIN 46 0 @I52@ INDI 1 NAME Angela /Dowding/ 1 SEX F 1 BIRT 2 DATE 1919 1 FAMS @F28@ 1 RIN 50 0 @I53@ INDI 1 NAME Elizabeth Collingwood /Colvin/ 1 SEX F 1 BIRT 2 DATE 1924 1 FAMS @F29@ 1 RIN 53 0 @I54@ INDI 1 NAME Henry /Lascelles/ 1 SEX M 1 BIRT 2 DATE 1953 1 FAMS @F30@ 1 FAMC @F28@ 1 RIN 51 0 @I55@ INDI 1 NAME Martin /Lascelles/ 1 SEX M 1 BIRT 2 DATE 1963 1 FAMC @F29@ 1 RIN 54 0 @I56@ INDI 1 NAME Alexandra /Morton/ 1 SEX F 1 FAMS @F30@ 1 RIN 52 0 @I57@ INDI 1 NAME Alice Christabel /Montagu-Douglas/ 1 TITL Lady 1 SEX F 1 BIRT 2 DATE Wednesday, 25th December 1901 2 PLAC London,England 1 FAMS @F31@ 1 FAMC @F32@ 1 RIN 56 0 @I58@ INDI 1 NAME William Henry Andrew/Windsor/ 1 TITL Prince 1 SEX M 1 BIRT 2 DATE Thursday, 18th December 1941 2 PLAC Hadley Common,Hertfordshire,England 1 CHR 2 DATE Sunday, 22nd February 1942 2 PLAC Private Chapel,Windsor Castle,Berkshire,England 1 DEAT 2 DATE Monday, 28th August 1972 2 PLAC Near,Wolverhampton,England 1 FAMC @F31@ 1 RIN 57 0 @I59@ INDI 1 NAME Richard Alexander Walter/Windsor/ 1 TITL Prince 1 SEX M 1 BIRT 2 DATE Saturday, 26th August 1944 2 PLAC Hadley Common,Hertfordshire,England 1 CHR 2 DATE Friday, 20th October 1944 2 PLAC Private Chapel,Windsor Castle,Berkshire,England 1 FAMS @F33@ 1 FAMC @F31@ 1 RIN 58 0 @I60@ INDI 1 NAME Birgitte of_Denmark /von_Deurs/ 1 TITL Duchess 1 SEX F 1 BIRT 2 DATE 1947 1 FAMS @F33@ 1 RIN 59 0 @I61@ INDI 1 NAME Alexander Patrick Gregers// 1 TITL Earl of Ulster 1 SEX M 1 BIRT 2 DATE Thursday, 24th October 1974 2 PLAC St. Marys Hosp.,Paddington,London,England 1 CHR 2 DATE Sunday, 9th February 1975 2 PLAC Barnwell Church 1 FAMC @F33@ 1 RIN 60 0 @I62@ INDI 1 NAME Davina Elizabeth Alice/Windsor/ 1 TITL Lady 1 SEX F 1 BIRT 2 DATE Saturday, 19th November 1977 1 CHR 2 PLAC Barnwell Church,,England 1 FAMC @F33@ 1 RIN 61 0 @I63@ INDI 1 NAME Rose Victoria Birgitte/Windsor/ 1 TITL Lady 1 SEX F 1 BIRT 2 DATE Saturday, 1st March 1980 2 PLAC St. Marys Hosp.,Paddington,England 1 CHR 2 DATE Sunday, 13th July 1980 2 PLAC Barnwell Church,,England 1 FAMC @F33@ 1 RIN 62 0 @I64@ INDI 1 NAME Marina of_Greece // 1 TITL Princess 1 SEX F 1 BIRT 2 DATE Friday, 30th November 1906 2 PLAC Athens,Greece 1 DEAT 2 DATE 1968 2 PLAC Kensington,Palace,,England 1 FAMS @F34@ 1 FAMC @F35@ 1 RIN 64 0 @I65@ INDI 1 NAME Edward George Nicholas/Windsor/ 1 TITL Duke of Kent 1 SEX M 1 BIRT 2 DATE Monday, 9th September 1935 2 PLAC 3 Belgrave Sq.,,England 1 FAMS @F36@ 1 FAMC @F34@ 1 RIN 65 0 @I66@ INDI 1 NAME Alexandra /Windsor/ 1 TITL Princess 1 SEX F 1 BIRT 2 DATE Friday, 25th December 1936 1 FAMS @F41@ 1 FAMC @F34@ 1 RIN 71 0 @I67@ INDI 1 NAME Michael /Windsor/ 1 TITL Prince 1 SEX M 1 BIRT 2 DATE Saturday, 4th July 1942 2 PLAC Coppins,,England 1 FAMS @F44@ 1 FAMC @F34@ 1 RIN 78 0 @I68@ INDI 1 NAME Katharine /Worsley/ 1 TITL Duchess of Kent 1 SEX F 1 BIRT 2 DATE 1933 1 FAMS @F36@ 1 FAMC @F37@ 1 RIN 66 0 @I69@ INDI 1 NAME George Philip of_St._Andrews/Windsor/ 1 TITL Earl 1 SEX M 1 BIRT 2 DATE Tuesday, 26th June 1962 1 CHR 2 DATE Friday, 14th September 1962 2 PLAC Buckingham,Palace,Music Room,England 1 FAMS @F38@ 1 FAMC @F36@ 1 RIN 67 0 @I70@ INDI 1 NAME Helen Marina Lucy/Windsor/ 1 TITL Lady 1 SEX F 1 BIRT 2 DATE Tuesday, 28th April 1964 1 CHR 2 DATE Tuesday, 12th May 1964 2 PLAC Private Chapel,Windsor Castle,Berkshire,England 1 FAMC @F36@ 1 RIN 69 0 @I71@ INDI 1 NAME Nicholas Charles Edward/Windsor/ 1 TITL Lord 1 SEX M 1 BIRT 2 DATE Saturday, 25th July 1970 2 PLAC Kings College,Hospital,Denmark Hill 1 CHR 2 PLAC Private Chapel,Windsor Castle,Berkshire,England 1 FAMC @F36@ 1 RIN 70 0 @I72@ INDI 1 NAME Sylvana /Tomaselli/ 1 SEX F 1 BIRT 2 DATE ABT 1957 2 PLAC Canada 1 FAMS @F39@ 1 FAMS @F38@ 1 FAMC @F40@ 1 RIN 68 0 @I73@ INDI 1 NAME Angus /Ogilvy/ 1 TITL Hon. 1 SEX M 1 BIRT 2 DATE 1928 1 FAMS @F41@ 1 RIN 72 0 @I74@ INDI 1 NAME James Robert Bruce/Ogilvy/ 1 SEX M 1 BIRT 2 DATE Saturday, 29th February 1964 2 PLAC Thatched House,Lodge,,England 1 FAMS @F42@ 1 FAMC @F41@ 1 RIN 73 0 @I75@ INDI 1 NAME Marina Victoria Alexandra/Ogilvy/ 1 SEX F 1 BIRT 2 DATE Sunday, 31st July 1966 2 PLAC Thatched House,Lodge,Richmond Park,England 1 FAMS @F43@ 1 FAMC @F41@ 1 RIN 75 0 @I76@ INDI 1 NAME Julia /Rawlinson/ 1 SEX F 1 FAMS @F42@ 1 RIN 74 0 @I77@ INDI 1 NAME Paul /Mowatt/ 1 SEX M 1 BIRT 2 DATE ABT 1962 1 FAMS @F43@ 1 RIN 76 0 @I78@ INDI 1 NAME /Mowatt/ 1 SEX F 1 BIRT 2 DATE Saturday, 26th May 1990 1 FAMC @F43@ 1 RIN 77 0 @I79@ INDI 1 NAME Marie-Christine /von_Reibnitz/ 1 TITL Baroness 1 SEX F 1 BIRT 2 DATE Monday, 15th January 1945 2 PLAC Czechoslovakia 1 FAMS @F45@ 1 FAMS @F44@ 1 RIN 79 0 @I80@ INDI 1 NAME Frederick /Windsor/ 1 TITL Lord 1 SEX M 1 BIRT 2 DATE Friday, 6th April 1979 2 PLAC St. Mary's Hosp.,Paddington,London,England 1 CHR 2 DATE Wednesday, 11th July 1979 2 PLAC Chapel Royal,St. James Palace,England 1 FAMC @F44@ 1 RIN 80 0 @I81@ INDI 1 NAME Gabriella Marina Alexandra/Windsor/ 1 TITL Lady 1 SEX F 1 BIRT 2 DATE Thursday, 23rd April 1981 2 PLAC ,,England 1 CHR 2 DATE Monday, 8th June 1981 2 PLAC Chapel Royal,St. James Palace,England 1 FAMC @F44@ 1 RIN 81 0 @I82@ INDI 1 NAME B1 C1 1 BIRT 2 DATE Saturday, 1st January 2000 2 AGE 0 1 BIRT 2 DATE Sunday, 2nd January 2000 1 RIN 83 1 NOTE Line 1 2 CONT Line 2 2 CONT Lin 2 CONC e 3 2 CONT Line 2 CONC 4 0 @I83@ INDI 1 NAME A2 B2 C2 1 NOTE @N1@ 1 RIN 84 0 @I84@ INDI 1 NAME B2 C2 D2 1 RIN 85 0 @I85@ INDI 1 NAME A2 B2 C2 D2 1 RIN 86 0 @I86@ INDI 1 NAME A3B3 C3 D3 1 RIN 87 0 @I87@ INDI 1 NAME A3 B3 C3D3 1 RIN 88 0 @I88@ INDI 1 NAME A3B3 C3D3 1 RIN 89 0 @I89@ INDI 1 NAME a3b3 c3d3 1 RIN 90 0 @I90@ INDI 1 NAME A4B4C4D4 1 RIN 91 0 @I91@ INDI 1 NAME a4b4c4d4 1 RIN 92 0 @F14@ FAM 1 HUSB @I29@ 1 WIFE @I30@ 1 CHIL @I19@ 1 MARR 2 DATE Tuesday, 10th March 1863 2 PLAC St. George Chap.,Windsor,,England 1 RIN 94 0 @F46@ FAM 1 CHIL @I29@ 1 DIV N 1 MARR 2 DATE Monday, 10th February 1840 2 PLAC Chapel Royal,St. James Palace,England 1 RIN 93 0 @F47@ FAM 1 CHIL @I30@ 1 MARR 2 DATE 1842 1 RIN 116 0 @F10@ FAM 1 HUSB @I19@ 1 WIFE @I20@ 1 CHIL @I21@ 1 CHIL @I7@ 1 CHIL @I22@ 1 CHIL @I23@ 1 CHIL @I24@ 1 CHIL @I25@ 1 MARR 2 DATE Thursday, 6th July 1893 2 PLAC Chapel Royal,St. James Palace 1 RIN 95 0 @F15@ FAM 1 CHIL @I20@ 1 RIN 111 0 @F16@ FAM 1 HUSB @I21@ 1 WIFE @I31@ 1 DIV N 1 MARR 2 DATE Thursday, 3rd June 1937 2 PLAC Chateau de Cande,Monts,,France 1 RIN 104 0 @F17@ FAM 1 WIFE @I31@ 1 DIV Y 1 MARR 2 DATE 1916 1 RIN 106 0 @F18@ FAM 1 WIFE @I31@ 1 DIV Y 1 MARR 2 DATE 1928 1 RIN 107 0 @F19@ FAM 1 CHIL @I31@ 1 RIN 115 0 @F2@ FAM 1 HUSB @I7@ 1 WIFE @I8@ 1 CHIL @I1@ 1 CHIL @I9@ 1 DIV N 1 MARR 2 DATE Thursday, 26th April 1923 1 RIN 96 0 @F11@ FAM 1 CHIL @I8@ 1 RIN 112 0 @F1@ FAM 1 HUSB @I2@ 1 WIFE @I1@ 1 CHIL @I3@ 1 CHIL @I4@ 1 CHIL @I5@ 1 CHIL @I6@ 1 DIV N 1 MARR 2 DATE Thursday, 20th November 1947 2 PLAC Westminster,Abbey,London,England 1 RIN 98 0 @F3@ FAM 1 CHIL @I2@ 1 MARR 2 DATE 1903 1 RIN 108 0 @F4@ FAM 1 HUSB @I3@ 1 WIFE @I10@ 1 CHIL @I11@ 1 CHIL @I12@ 1 DIV N 1 MARR 2 DATE Wednesday, 29th July 1981 2 PLAC St. Paul's,Cathedral,London,England 1 RIN 100 0 @F5@ FAM 1 CHIL @I10@ 1 DIV Y 1 MARR 2 DATE 1954 2 PLAC Westminster,Abbey,London,England 1 RIN 118 0 @F6@ FAM 1 HUSB @I13@ 1 WIFE @I4@ 1 CHIL @I14@ 1 CHIL @I15@ 1 DIV N 1 MARR 2 DATE Wednesday, 14th November 1973 2 PLAC Westminster,Abbey,London,England 1 RIN 99 0 @F7@ FAM 1 CHIL @I13@ 1 RIN 132 0 @F8@ FAM 1 HUSB @I5@ 1 WIFE @I16@ 1 CHIL @I17@ 1 CHIL @I18@ 1 MARR 2 DATE Wednesday, 23rd July 1986 2 PLAC Westminster,Abbey,London,England 1 RIN 113 0 @F9@ FAM 1 CHIL @I16@ 1 DIV Y 1 MARR 2 DATE Thursday, 19th January 1956 2 PLAC St. Margarets,Westminster,England 1 RIN 114 0 @F12@ FAM 1 HUSB @I26@ 1 WIFE @I9@ 1 CHIL @I27@ 1 CHIL @I28@ 1 DIV Y 1 MARR 2 DATE Friday, 6th May 1960 2 PLAC Westminster,Cathedral,London,England 1 RIN 97 0 @F13@ FAM 1 HUSB @I26@ 1 MARR 2 DATE Sunday, 17th December 1978 1 RIN 136 0 @F20@ FAM 1 HUSB @I32@ 1 WIFE @I22@ 1 CHIL @I33@ 1 CHIL @I34@ 1 MARR 2 DATE Tuesday, 28th February 1922 2 PLAC Westminster,Abbey,London,England 1 RIN 102 0 @F21@ FAM 1 HUSB @I33@ 1 WIFE @I35@ 1 CHIL @I37@ 1 CHIL @I38@ 1 CHIL @I39@ 1 DIV Y 1 MARR 2 DATE 1949 1 RIN 119 0 @F22@ FAM 1 HUSB @I33@ 1 WIFE @I36@ 1 CHIL @I40@ 1 MARR 2 DATE 1967 1 RIN 121 0 @F23@ FAM 1 CHIL @I35@ 1 RIN 139 1 SOUR @S1@ 2 PAGE 1 0 @F24@ FAM 1 HUSB @I37@ 1 WIFE @I41@ 1 CHIL @I42@ 1 CHIL @I43@ 1 CHIL @I44@ 1 CHIL @I45@ 1 MARR 2 DATE 1979 1 RIN 126 0 @F25@ FAM 1 HUSB @I38@ 1 WIFE @I46@ 1 CHIL @I47@ 1 CHIL @I48@ 1 MARR 2 DATE 1973 1 RIN 127 0 @F26@ FAM 1 HUSB @I39@ 1 WIFE @I49@ 1 CHIL @I50@ 1 CHIL @I51@ 1 MARR 2 DATE 1981 1 RIN 128 0 @F27@ FAM 1 WIFE @I36@ 1 RIN 138 0 @F28@ FAM 1 HUSB @I34@ 1 WIFE @I52@ 1 CHIL @I54@ 1 DIV Y 1 MARR 2 DATE 1952 1 RIN 120 0 @F29@ FAM 1 HUSB @I34@ 1 WIFE @I53@ 1 CHIL @I55@ 1 MARR 2 DATE 1978 1 RIN 122 0 @F30@ FAM 1 HUSB @I54@ 1 WIFE @I56@ 1 MARR 2 DATE 1979 1 RIN 130 0 @F31@ FAM 1 HUSB @I23@ 1 WIFE @I57@ 1 CHIL @I58@ 1 CHIL @I59@ 1 MARR 2 DATE Wednesday, 6th November 1935 2 PLAC Buckingham,Palace,London,England 1 RIN 103 0 @F32@ FAM 1 CHIL @I57@ 1 RIN 125 0 @F33@ FAM 1 HUSB @I59@ 1 WIFE @I60@ 1 CHIL @I61@ 1 CHIL @I62@ 1 CHIL @I63@ 1 MARR 2 DATE Wednesday, 19th July 1972 1 RIN 105 0 @F34@ FAM 1 HUSB @I24@ 1 WIFE @I64@ 1 CHIL @I65@ 1 CHIL @I66@ 1 CHIL @I67@ 1 MARR 2 DATE Thursday, 29th November 1934 2 PLAC Westminster,Abbey,London,England 1 RIN 101 0 @F35@ FAM 1 CHIL @I64@ 1 MARR 2 DATE 1902 1 RIN 117 0 @F36@ FAM 1 HUSB @I65@ 1 WIFE @I68@ 1 CHIL @I69@ 1 CHIL @I70@ 1 CHIL @I71@ 1 MARR 2 DATE 1961 1 RIN 110 0 @F37@ FAM 1 CHIL @I68@ 1 RIN 129 0 @F38@ FAM 1 HUSB @I69@ 1 WIFE @I72@ 1 MARR 2 DATE Tuesday, 19th January 1988 1 RIN 133 0 @F39@ FAM 1 WIFE @I72@ 1 DIV Y 1 RIN 134 0 @F40@ FAM 1 CHIL @I72@ 1 DIV Y 1 RIN 135 0 @F41@ FAM 1 HUSB @I73@ 1 WIFE @I66@ 1 CHIL @I74@ 1 CHIL @I75@ 1 MARR 2 DATE Friday, 19th April 1963 2 PLAC ,,England 1 RIN 109 0 @F42@ FAM 1 HUSB @I74@ 1 WIFE @I76@ 1 MARR 2 DATE AFT 1989 1 RIN 137 0 @F43@ FAM 1 HUSB @I77@ 1 WIFE @I75@ 1 CHIL @I78@ 1 MARR 2 DATE Monday, 19th February 1990 1 RIN 131 0 @F44@ FAM 1 HUSB @I67@ 1 WIFE @I79@ 1 CHIL @I80@ 1 CHIL @I81@ 1 MARR 2 DATE Friday, 30th June 1978 2 PLAC Vienna,Austria 1 RIN 123 0 @F45@ FAM 1 WIFE @I79@ 1 DIV Y 1 MARR 2 DATE Sunday, 19th September 1971 1 RIN 124 0 @N1@ NOTE Line 1 1 CONT Line 2 0 @S1@ SOUR 1 TEXT Source text 0 TRLR Gedcom-1.19/t/TEST.PL0000644000175000017500000000176112204002474012557 0ustar pjcjpjcj#!perl use strict; use warnings FATAL => "all"; use lib qw(lib ../lib); use Apache::TestRun (); package MyTest; use vars qw(@ISA); @ISA = qw(Apache::TestRun); #subclass new_test_config to add some config vars which will #be replaced in generated config, see t/conf/extra.conf.in #'make test' runs -clean by default, so to actually see the replacements: #perl t/TEST apxs ... #cat t/conf/extra.conf #perl t/TEST -clean sub new_test_config { my $self = shift; # $self->{conf_opts}->{authname} = 'gold club'; # $self->{conf_opts}->{allowed_users} = 'dougm sterling'; $self->{conf_opts}{defines} .= " TEST"; $self->{conf_opts}{defines} .= " GEDCOM_TEST" if $ENV{GEDCOM_TEST}; return $self->SUPER::new_test_config; } sub bug_report { my $self = shift; print <new->run(@ARGV); Gedcom-1.19/t/namefreq.t0000755000175000017500000000162312204002474013526 0ustar pjcjpjcj#!/usr/local/bin/perl -w # Copyright 1999-2013, Paul Johnson (paul@pjcj.net) # 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.19 - 18th August 2013 # This is really just a test of the lifelines testing mechanism, but it # also serves as a very basic lifelines test. use strict; use lib -d "t" ? "t" : ".."; use Lines; use File::Spec; my $report = File::Spec->catfile((-d "t" ? ("t/") : ()), "lines", "namefreq"); Lines->test(tests => 82, report => $report, lines_report => "$report.l", report_command => $ENV{lines} ? "$report.l\n" : undef, generate => $ENV{generate}, perl_program => "$report.plx", perl_report => "$report.p", perl_command => ""); Gedcom-1.19/t/resolve_read_only.t0000755000175000017500000000060712204002474015444 0ustar pjcjpjcj#!/usr/local/bin/perl -w # Copyright 1999-2013, Paul Johnson (paul@pjcj.net) # 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.19 - 18th August 2013 use strict; use lib -d "t" ? "t" : ".."; use Basic (resolve => "resolve_xrefs", read_only => 1); Gedcom-1.19/ged0000755000175000017500000001374312204002473011767 0ustar pjcjpjcj#!/usr/local/bin/perl -w # Copyright 1998-2013, Paul Johnson (paul@pjcj.net) # 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.19 - 18th August 2013 use strict; require 5.005; use diagnostics; use Data::Dumper; $Data::Dumper::Indent = 1; use Gedcom 1.19; use vars qw( $VERSION ); $VERSION = "1.19"; 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 => $gedcom_file, # grammar_version => "5.5.1", # grammar_file => "gedcom-5.5.1.grammar", # callback => sub { print "." }, # read_only => 1, ); if (0) { my $i = $ged->get_individual("I1"); my $n2 = $ged->add_note({ xref => "NN2" }, "top level"); $n2->add("cont", "line 2"); my $note1 = $i->add("note", "qaz"); $note1->add("cont", "q2"); my $note2 = $i->add("note", $n2); $note2->add("cont", "q3"); $ged->order; print "\nvalidating..."; $ged->validate; print "\nwriting..."; $ged->write("$gedcom_file.new"); } if (0) { my $i = $ged->get_individual("I1"); my $obj1 = $i->add("OBJE", 12); # use DDS; print STDERR Dump $obj; my $obj2 = $i->add("OBJE"); $obj2->add("FORM", "qqq"); $obj2->add("FILE", "rrr"); print "\nvalidating..."; $ged->validate; print "\nwriting..."; $ged->write("$gedcom_file.new"); } if (0) { $ged = Gedcom->new(grammar_version => 5.5 ); my $record=$ged->add_source(); my $obje=$record->add("obje"); $obje->add("form", "png"); $obje->add("file", "somefile"); $ged->write("$gedcom_file.new"); } if (0) { my $i = $ged->get_individual("I1"); print "NOTE [", exists $i->get_record("note")->{grammar}{value}, "]\n"; print "BIRT [", exists $i->get_record("birt")->{grammar}{value}, "]\n"; } if (0) { # use DDS; print STDERR Dump $ged; my $i = $ged->get_individual("I8"); print $i->{grammar}->valid_items->{NAME}[0]{max}; print $i->{grammar}->valid_items->{SEX}[0]{max}; print "\n"; for ($i->items) { my $t = $_->{tag}; my $vi = $i->{grammar}->valid_items; print "$t: $vi->{$t}[0]{min} - $vi->{$t}[0]{max}\n"; } } if (0) { print "\nchanging BIRT to CHR..."; my $i = $ged->get_individual("I8"); for ($i->items) { $_->{tag} = "CHR" if $_->{tag} eq "BIRT"; } $ged->validate; print "\nwriting..."; $ged->write("$gedcom_file.new"); } if (0) { $ged->resolve_xrefs; print "\nmerging notes..."; my @notes = grep $_->tag eq "NOTE", $ged->{record}->items; my %notes; my @dups; for my $note (@notes) { my $text = $note->full_value; if (exists $notes{$text}) { print "NOTE ", $note->xref, " matches $notes{$text}\n"; $note->{xref} = $notes{$text}; push @dups, $note; } else { $notes{$text} = $note->xref; } } $ged->unresolve_xrefs; $_->delete for @dups; $ged->validate; print "\nwriting..."; $ged->write("$gedcom_file.new"); } if (0) { my $age = sub { Date_Cmp(ParseDate($a->get_value("birth date") || ""), ParseDate($b->get_value("birth date") || "")) }; print "\nrenumbering..."; my @i = sort { $age->($a) <=> $age->($b) } $ged->individuals; $ged->renumber(xrefs => [ map $_->xref, @i ]); $ged->validate; print "\nwriting..."; $ged->write("$gedcom_file.new"); } if (0) { # 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"; } if (0) { my $i = $ged->get_individual("I31"); my $famc = $i->famc; my $s = $famc->source; print "source: $s\n"; my ($source) = grep $_->xref eq $s, $ged->{record}->record("source"); print $source->text, "\n"; my $s2 = $ged->get_source($s); print $s2->text, "\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 (0) { 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); print "\nwriting..."; $ged->write("$gedcom_file.new"); print "\n"; } 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 Gedcom-1.19/gedcom-5.5.1.grammar0000644000175000017500000005321112204002473014546 0ustar pjcjpjcj GEDCOM: = 0 <
> {1:1} 0 <> {0:1} 0 <> {0:M} 0 TRLR {1:1} HEADER: = n HEAD {1:1} +1 SOUR {1:1} +2 VERS {0:1} +2 NAME {0:1} +2 CORP {0:1} +3 <> {0:1} +2 DATA {0:1} +3 DATE {0:1} +3 COPR {0:1} +4 CONT {0:M} +4 CONC {0:M} +1 DEST {0:1} +1 DATE {0:1} +2 TIME {0:1} +1 SUBM @@ {1:1} +1 SUBN @@ {0:1} +1 FILE {0:1} +1 COPR {0:1} +1 GEDC {1:1} +2 VERS {1:1} +2 FORM {1:1} +1 CHAR {1:1} +2 VERS {0:1} +1 LANG {0:1} +1 PLAC {0:1} +2 FORM {1:1} +1 NOTE {0:1} +2 CONT {0:M} +2 CONC {0:M} RECORD: = [ n <> {1:1} | n <> {1:1} | n <> {1:1} | n <> {1:1} | n <> {1:1} | n <> {1:1} | n <> {1:1} ] FAM_RECORD: = n @@ FAM {1:1} +1 RESN {0:1} +1 <> {0:M} +1 HUSB @@ {0:1} +1 WIFE @@ {0:1} +1 CHIL @@ {0:M} +1 NCHI {0:1} +1 SUBM @@ {0:M} +1 <> {0:M} +1 REFN {0:M} +2 TYPE {0:1} +1 RIN {0:1} +1 <> {0:1} +1 <> {0:M} +1 <> {0:M} +1 <> {0:M} INDIVIDUAL_RECORD: = n @@ INDI {1:1} +1 RESN {0:1} +1 <> {0:M} +1 SEX {0:1} +1 <> {0:M} +1 <> {0:M} +1 <> {0:M} +1 <> {0:M} +1 <> {0:M} +1 SUBM @@ {0:M} +1 <> {0:M} +1 ALIA @@ {0:M} +1 ANCI @@ {0:M} +1 DESI @@ {0:M} +1 RFN {0:1} +1 AFN {0:1} +1 REFN {0:M} +2 TYPE {0:1} +1 RIN {0:1} +1 <> {0:1} +1 <> {0:M} +1 <> {0:M} +1 <> {0:M} MULTIMEDIA_RECORD: = n @@ OBJE {1:1} +1 FILE {1:M} +2 FORM {1:1} +3 TYPE {0:1} +2 TITL {0:1} +1 REFN {0:M} +2 TYPE {0:1} +1 RIN {0:1} +1 <> {0:M} +1 <> {0:M} +1 <> {0:1} NOTE_RECORD: = n @@ NOTE {1:1} +1 CONC {0:M} +1 CONT {0:M} +1 REFN {0:M} +2 TYPE {0:1} +1 RIN {0:1} +1 <> {0:M} +1 <> {0:1} REPOSITORY_RECORD: = n @@ REPO {1:1} +1 NAME {1:1} +1 <> {0:1} +1 <> {0:M} +1 REFN {0:M} +2 TYPE {0:1} +1 RIN {0:1} +1 <> {0:1} SOURCE_RECORD: = n @@ SOUR {1:1} +1 DATA {0:1} +2 EVEN {0:M} +3 DATE {0:1} +3 PLAC {0:1} +2 AGNC {0:1} +2 <> {0:M} +1 AUTH {0:1} +2 CONT {0:M} +2 CONC {0:M} +1 TITL {0:1} +2 CONT {0:M} +2 CONC {0:M} +1 ABBR {0:1} +1 PUBL {0:1} +2 CONT {0:M} +2 CONC {0:M} +1 TEXT {0:1} +2 CONT {0:M} +2 CONC {0:M} +1 <> {0:1} +1 REFN {0:M} +2 TYPE {0:1} +1 RIN {0:1} +1 <> {0:1} +1 <> {0:M} +1 <> {0:M} SUBMISSION_RECORD: = n @@ SUBN {1:1] +1 SUBM @@ {0:1} +1 FAMF {0:1} +1 TEMP {0:1} +1 ANCE {0:1} +1 DESC {0:1} +1 ORDI {0:1} +1 RIN {0:1} +1 <> {0:M} +1 <> {0:1} SUBMITTER_RECORD: = n @@ SUBM {1:1} +1 NAME {1:1} +1 <> {0:1} +1 <> {0:M} +1 LANG {0:3} +1 RFN {0:1} +1 RIN {0:1} +1 <> {0:M} +1 <> {0:1} ADDRESS_STRUCTURE: = n ADDR {0:1} +1 CONT {0:3} +1 ADR1 {0:1} +1 ADR2 {0:1} +1 ADR3 {0:1} +1 CITY {0:1} +1 STAE {0:1} +1 POST {0:1} +1 CTRY {0:1} n PHON {0:3} n EMAIL {0:3} n FAX {0:3} n WWW {0:3} ASSOCIATION_STRUCTURE: = n ASSO @@ {0:1} +1 RELA {1:1} +1 <> {0:M} +1 <> {0:M} CHANGE_DATE: = n CHAN {1:1} +1 DATE {1:1} +2 TIME {0:1} +1 <> {0:M} CHILD_TO_FAMILY_LINK: = n FAMC @@ {1:1} +1 PEDI {0:1} +1 STAT {0:1} +1 <> {0:M} EVENT_DETAIL: = n TYPE {0:1} n DATE {0:1} n <> {0:1} n <> {0:1} n AGNC {0:1} n RELI {0:1} n CAUS {0:1} n RESN {0:1} n <> {0:M} n <> {0:M} n <> {0:M} FAMILY_EVENT_DETAIL: = n HUSB {0:1} +1 AGE {1:1} n WIFE {0:1} +1 AGE {1:1} n <> {0:1} FAMILY_EVENT_STRUCTURE: = [ n ANUL {1:1} +1 <> {0:1} | n CENS {1:1} +1 <> {0:1} | n DIV {1:1} +1 <> {0:1} | n DIVF {1:1} +1 <> {0:1} | n ENGA {1:1} +1 <> {0:1} | n MARB {1:1} +1 <> {0:1} | n MARC {1:1} +1 <> {0:1} | n MARR {1:1} +1 <> {0:1} | n MARL {1:1} +1 <> {0:1} | n MARS {1:1} +1 <> {0:1} | n RESI {1:1} +1 <> {0:1} | n EVEN {1:1} +1 <> {0:1} ] INDIVIDUAL_ATTRIBUTE_STRUCTURE: = [ n CAST {1:1} +1 <> {0:1} | n DSCR {1:1} +1 CONT {0:M} +1 CONC {0:M} +1 <> {0:1} | n EDUC {1:1} +1 <> {0:1} | n IDNO {1:1} +1 <> {0:1} | n NATI {1:1} +1 <> {0:1} | n NCHI {1:1} +1 <> {0:1} | n NMR {1:1} +1 <> {0:1} | n OCCU {1:1} +1 <> {0:1} | n PROP {1:1} +1 <> {0:1} | n RELI {1:1} +1 <> {0:1} | n RESI {1:1} +1 <> {0:1} | n SSN {0:1} +1 <> {0:1} | n TITL {1:1} +1 <> {0:1} | n FACT {1:1} +1 <> {0:1} ] INDIVIDUAL_EVENT_DETAIL: = n <> {1:1} n AGE <> {0:1} INDIVIDUAL_EVENT_STRUCTURE: = [ n BIRT {1:1} +1 <> {0:1} +1 FAMC @@ {0:1} | n CHR {1:1} +1 <> {0:1} +1 FAMC @@ {0:1} | n DEAT {1:1} +1 <> {0:1} | n BURI {1:1} +1 <> {0:1} | n CREM {1:1} +1 <> {0:1} | n ADOP {1:1} +1 <> {0:1} +1 FAMC @@ {0:1} +2 ADOP {0:1} | n BAPM {1:1} +1 <> {0:1} | n BARM {1:1} +1 <> {0:1} | n BASM {1:1} +1 <> {0:1} | n BLES {1:1} +1 <> {0:1} | n CHRA {1:1} +1 <> {0:1} | n CONF {1:1} +1 <> {0:1} | n FCOM {1:1} +1 <> {0:1} | n ORDN {1:1} +1 <> {0:1} | n NATU {1:1} +1 <> {0:1} | n EMIG {1:1} +1 <> {0:1} | n IMMI {1:1} +1 <> {0:1} | n CENS {1:1} +1 <> {0:1} | n PROB {1:1} +1 <> {0:1} | n WILL {1:1} +1 <> {0:1} | n GRAD {1:1} +1 <> {0:1} | n RETI {1:1} +1 <> {0:1} | n EVEN {1:1} +1 <> {0:1} ] LDS_INDIVIDUAL_ORDINANCE: = [ n BAPL {1:1} +1 DATE {0:1} +1 TEMP {0:1} +1 PLAC {0:1} +1 STAT {0:1} +2 DATE {1:1} +1 <> {0:M} +1 <> {0:M} | n CONL {1:1} +1 DATE {0:1} +1 TEMP {0:1} +1 PLAC {0:1} +1 STAT {0:1} +2 DATE {1:1} +1 <> {0:M} +1 <> {0:M} | n ENDL {1:1} +1 DATE {0:1} +1 TEMP {0:1} +1 PLAC {0:1} +1 STAT {0:1} +2 DATE {1:1} +1 <> {0:M} +1 <> {0:M} | n SLGC {1:1} +1 DATE {0:1} +1 TEMP {0:1} +1 PLAC {0:1} +1 FAMC @@ {1:1} +1 STAT {0:1} +2 DATE {1:1} +1 <> {0:M} +1 <> {0:M} ] LDS_SPOUSE_SEALING: = n SLGS {1:1} +1 DATE {0:1} +1 TEMP {0:1} +1 PLAC {0:1} +1 STAT {0:1} +2 DATE {1:1} +1 <> {0:M} +1 <> {0:M} MULTIMEDIA_LINK: = [ n OBJE @@ {1:1} | n OBJE {1:1} +1 FILE {1:M} +2 FORM {1:1} +3 TYPE {0:1} +2 TITL {0:1} ] NOTE_STRUCTURE: = [ n NOTE @@ {1:1} | n NOTE {1:1} +1 CONC {0:M} +1 CONT {0:M} ] PERSONAL_NAME_PIECES: = n NPFX {0:1} n GIVN {0:1} n NICK {0:1} n SPFX {0:1} n SURN {0:1} n NSFX {0:1} n <> {0:M} n <> {0:M} PERSONAL_NAME_STRUCTURE: = n NAME {1:1} +1 TYPE {0:1} +1 <> {0:1} +1 FONE {0:M} +2 TYPE {1:1} +2 <> {0:1} +1 ROMN {0:M} +2 TYPE {1:1} +2 <> {0:1} PLACE_STRUCTURE: = n PLAC {1:1} +1 FORM {0:1} +1 FONE {0:M} +2 TYPE {1:1} +1 ROMN {0:M} +2 TYPE {1:1} +1 MAP {0:1} +2 LATI {1:1} +2 LONG {1:1} +1 <> {0:M} SOURCE_CITATION: = [ n SOUR @@ {1:1} +1 PAGE {0:1} +1 EVEN {0:1} +2 ROLE {0:1} +1 DATA {0:1} +2 DATE {0:1} +2 TEXT {0:M} +3 CONC {0:M} +3 CONT {0:M} +1 <> {0:M} +1 <> {0:M} +1 QUAY {0:1} | n SOUR {1:1} +1 CONC {0:M} +1 CONT {0:M} +1 TEXT {0:M} +2 CONC {0:M} +2 CONT {0:M} +1 <> {0:M} +1 <> {0:M} +1 QUAY {0:1} ] SOURCE_REPOSITORY_CITATION: = n REPO @@ {1:1} +1 <> {0:M} +1 CALN {0:M} +2 MEDI {0:1} SPOUSE_TO_FAMILY_LINK: = n FAMS @@ {1:1} +1 <> {0:M} Gedcom-1.19/MANIFEST0000644000175000017500000000227512204002636012432 0ustar pjcjpjcj.travis.yml cgi-bin/gedcom.cgi CHANGES ged gedcom-5.5-strict.grammar gedcom-5.5.1.grammar gedcom-5.5.grammar gedcom.vim gedcom_compare install/buildperl install/SETUP install/System.pm lib/Gedcom.pm lib/Gedcom/CGI.pm lib/Gedcom/Comparison.pm lib/Gedcom/Event.pm lib/Gedcom/Family.pm lib/Gedcom/Grammar.pm lib/Gedcom/Grammar_5_5.pm lib/Gedcom/Grammar_5_5_1.pm lib/Gedcom/Individual.pm lib/Gedcom/Item.pm lib/Gedcom/LifeLines.pm lib/Gedcom/Record.pm lib/Gedcom/WebServices.pm lines2perl Makefile.PL MANIFEST This list of files parse_grammar README royal.ged setup t/Basic.pm t/basic.t t/bias.t t/birthdates.t t/conf/extra.conf.in t/conf/gedcom.conf t/ged_create.t t/grammar_file.t t/Lines.pm t/lines.t t/lines/bias t/lines/bias.l t/lines/bias.plx t/lines/lines t/lines/lines.l t/lines/lines.plx t/lines/namefreq t/lines/namefreq.l t/lines/namefreq.plx t/namefreq.t t/parse_grammar.t t/pod.t t/read_only.t t/resolve.t t/resolve_read_only.t t/TEST.PL t/ws_json.t t/ws_plain.t t/ws_xml.t tkged TODO utils/all_versions utils/makeh utils/session.vim META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Gedcom-1.19/gedcom_compare0000755000175000017500000000205712204002473014170 0ustar pjcjpjcj#!/usr/local/bin/perl -w # Copyright 2003-2013, Paul Johnson (paul@pjcj.net) # 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.19 - 18th August 2013 use strict; require 5.005; use Data::Dumper; $Data::Dumper::Indent = 1; use Gedcom 1.19; use vars qw( $VERSION ); $VERSION = "1.19"; $SIG{__WARN__} = sub { print STDERR "\n@_" }; sub main { my ($g1, $g2) = @ARGV; $| = 1; print "reading $g1 ..."; my $ged1 = Gedcom->new ( gedcom_file => $g1, callback => sub { print "." }, read_only => 0, ); print "\nreading $g2 ..."; my $ged2 = Gedcom->new ( gedcom_file => $g2, callback => sub { print "." }, read_only => 0, ); print "\n"; # my $comparison = $ged1->{record}->compare($ged2->{record}); my $comparison = $ged1->get_individual("I1")->compare($ged2->get_individual("I0003")); $comparison->print; # print Dumper $comparison; } main Gedcom-1.19/lines2perl0000755000175000017500000006126112204002474013306 0ustar pjcjpjcj#!/usr/local/bin/perl -w # Copyright 1999-2013, Paul Johnson (paul@pjcj.net) # 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.19 - 18th August 2013 use strict; require 5.005; use diagnostics; use Data::Dumper; use Getopt::Long; use FindBin; use lib $FindBin::Bin; use Parse::RecDescent; use Gedcom 1.19; use Gedcom::LifeLines 1.19; use vars qw( $VERSION $Prefix $Suffix ); $VERSION = "1.19"; sub _indent { join "", map { ref $_ ? _indent(@$_) : $_ } @_ } sub indent { # print STDERR "indenting @_\n"; my $i = _indent(@_); $i =~ s/^/ /gm; $i } my %Opts; GetOptions(\%Opts, "quiet!") or die "bad options"; sub msg { return if $Opts{quiet}; printf STDERR "%4d,%3d: ", shift, shift; print STDERR @_, "\n"; return } # TODO - use correct perl $Prefix = <<'EOH'; #!/usr/local/bin/perl -w # This program was generated by lines2perl, which is part of Gedcom.pm. # Gedcom.pm is Copyright 1999-2013, Paul Johnson (paul@pjcj.net) # Version 1.19 - 18th August 2013 # 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 use strict; require 5.005; use diagnostics; use integer; use Getopt::Long; use Gedcom::LifeLines 1.19; my $Ged; # Gedcom object my %Opts; # options my $_Traverse_sub; # subroutine for traverse sub out { print STDERR @_ unless $Opts{quiet} } sub outf { printf STDERR @_ unless $Opts{quiet} } sub initialise () { die "usage: $0 -gedcom_file file.ged\n" unless GetOptions(\%Opts, "gedcom_file=s", "quiet!", "validate!", ) and defined $Opts{gedcom_file}; local $SIG{__WARN__} = sub { out "\n@_" }; out "reading..."; $Ged = Gedcom->new ( gedcom_file => $Opts{gedcom_file}, callback => sub { out "." } ); if ($Opts{validate}) { out "\nvalidating..."; my %x; my $vcb = sub { my ($r) = @_; my $t = $r->{xref}; out "." if $t && !$x{$t}++; }; $Ged->validate($vcb); } out "\n"; set_ged($Ged); } $SIG{__WARN__} = sub { out $_[0] unless $_[0] =~ /^Use of uninitialized value/ }; EOH $Suffix = <<'EOS'; initialise(); main(); flush(); 0 EOS my $Grammar = <<'EOG'; { my (%Globals, %Locals, %Params); } program : declaration(s) /$/s { print $::Prefix, join("", @{$item[1]}), $::Suffix } | declaration : // { ::msg($thisline, $thiscolumn, "parsing declaration") } | comment | procedure_definition | global_statement { "$item[1];\n" } | list_statement { "$item[1];\n" } | table_statement { "$item[1];\n" } | indiset_statement { "$item[1];\n" } | include_statement { "$item[1];\n" } | statement : "}" | // { ::msg($thisline, $thiscolumn, "parsing statement") } | comment | constant { "display $item[1];\n" } | call_statement { "display $item[1];\n" } | builtin_function { "display $item[1];\n" } | emulated_function { "display $item[1];\n" } | builtin_procedure { "$item[1];\n" } | global_statement { "$item[1];\n" } | list_statement { "$item[1];\n" } | table_statement { "$item[1];\n" } | indiset_statement { "$item[1];\n" } | set_statement { "$item[1];\n" } | getintmsg_statement { "$item[1];\n" } | getstrmsg_statement { "$item[1];\n" } | getindimsg_statement { "$item[1];\n" } | continue_statement { "$item[1];\n" } | break_statement { "$item[1];\n" } | return_statement { "$item[1];\n" } | include_statement { "$item[1];\n" } | if_statement | while_statement | forlist_statement | spouses_statement | families_statement | forindi_statement | children_statement | forfam_statement | fornodes_statement | traverse_statement | forindiset_statement | non_call_statement { "display $item[1];\n" } | scalar ...!"(" { "display $item[1];\n" } | statements : ..."}" { [] } | statement statements { [$item[1], @{$item[2]}] } expression : ")" | // { ::msg($thisline, $thiscolumn, "parsing expression") } | constant | call_statement | builtin_function | emulated_function | non_call_statement | "(" ")" { "" } | "(" expression ")" { "($item[2])" } | scalar ...!"(" { $item[1] } | procedure_definition : ("proc" | "func") name "(" scalars(?) ")" "{" statements "}" { # warn "item is ", ::Dumper \@item; my $args = @{$item[4]} ? $item[4][0] =~ tr/$/$/ : 0; my $val = "sub $item[2] (" . '$' x $args . ")\n" . "{\n" . ($args ? (" my($item[4][0]) = \@_;\n") : "") . join("", map { qq( my \$$_;\n) } sort keys %Locals) . ::indent($item[7]) . ($item[1] eq "proc" ? " undef\n" : "") . "}\n\n"; %Locals = %Params = (); $val } comment : /\s*\/\*.*?\*\/\s*/s { my $comment = $item[1]; $comment =~ s/\n+$//; $comment =~ s/^/# /gm; $comment . "\n" } block : comment(s?) "{" statements "}" comment(s?) { "@{$item[1]}" . "{\n" . ::indent($item[3]) . "}\n@{$item[5]}" } condition_and_block : "(" scalar_assignment(?) expression ")" block { # warn "item is ", ::Dumper \@item; "(@{$item[2]}$item[3])\n$item[5]" } if_statement : "if" condition_and_block elsif_statement(s?) else_statement(?) { # warn "item is ", ::Dumper \@item; # local $"; # this line breaks the parser... "if $item[2]" . join "", @{$item[3]}, @{$item[4]} } elsif_statement : "elsif" condition_and_block { # warn "item is ", ::Dumper \@item; "elsif $item[2]" } else_statement : "else" block { # warn "item is ", ::Dumper \@item; "else\n$item[2]" } while_statement : "while" condition_and_block { # warn "item is ", ::Dumper \@item; "LOOP: while $item[2]" } forlist_statement : "forlist" "(" name "," scalar "," scalar ")" "{" statements "}" { # warn "item is ", ::Dumper \@item; "$item[7] = 0;\n" . "LOOP: for $item[5] (\@\$$item[3])\n" . "{\n" . " $item[7]++;\n" . ::indent($item[10]) . "}\n" } spouses_statement : "spouses" "(" expression "," scalar "," scalar "," scalar ")" "{" statements "}" { # warn "item is ", ::Dumper \@item; "$item[9] = 0;\n" . "LOOP: for $item[7] ($item[3]" . "->fams)\n" . "{\n" . " for $item[5] ($item[7]" . "->parents)\n" . " {\n" . " next if $item[5]" . "->xref eq " . "$item[3]" . "->xref;\n" . " $item[9]++;\n" . ::indent(::indent($item[12])) . " }\n" . "}\n" } families_statement : "families" "(" expression "," scalar "," scalar "," scalar ")" "{" statements "}" { # warn "item is ", ::Dumper \@item; "$item[9] = 0;\n" . "LOOP: for $item[5] ($item[3]" . "->fams)\n" . "{\n" . " for $item[7] ($item[5]" . "->parents || undef)\n" . " {\n" . " next if $item[7] && $item[7]" . "->xref eq " . "$item[3]" . "->xref;\n" . " $item[9]++;\n" . ::indent(::indent($item[12])) . " }\n" . "}\n" } forindi_statement : "forindi" "(" scalar "," scalar ")" "{" statements "}" { # warn "item is ", ::Dumper \@item; "$item[5] = 0;\n" . "LOOP: for $item[3] (\$Ged" . "->individuals)\n" . "{\n" . " $item[5]++;\n" . ::indent($item[8]) . "}\n" } children_statement : "children" "(" expression "," scalar "," scalar ")" "{" statements "}" { # warn "item is ", ::Dumper \@item; "$item[7] = 0;\n" . "LOOP: for $item[5] ( " . "do { my \$e = $item[3]; \$e ? \$e->children : ()} )\n" . "{\n" . " $item[7]++;\n" . ::indent(::indent($item[10])) . "}\n" } forfam_statement : "forfam" "(" scalar "," scalar ")" "{" statements "}" { # warn "item is ", ::Dumper \@item; "$item[5] = 0;\n" . "LOOP: for $item[3] (\$Ged" . "->families)\n" . "{\n" . " $item[5]++;\n" . ::indent($item[8]) . "}\n" } fornodes_statement : "fornodes" "(" expression "," scalar ")" "{" statements "}" { # warn "item is ", ::Dumper \@item; "LOOP: for $item[5] (\@{$item[3]" . "->_items})\n" . "{\n" . ::indent($item[8]) . "}\n" } traverse_statement : "traverse" "(" expression "," scalar "," scalar ")" "{" statements "}" { # warn "item is ", ::Dumper \@item; "\$_Traverse_sub = sub\n" . "{\n" . " my (\$_traverse_sub_node, " . "\$_traverse_sub_level) = \@_;\n" . " $item[5] = \$_traverse_sub_node;\n" . " $item[7] = \$_traverse_sub_level;\n" . ::indent($item[10]) . " LOOP: for my \$_traverse_sub_item " . "(\@{\$_traverse_sub_node" . "->_items})\n" . " {\n" . " \$_Traverse_sub->(\$_traverse_sub_item, " . "\$_traverse_sub_level + 1)\n" . " }\n" . "};\n" . "\$_Traverse_sub->($item[3], 0);\n" } forindiset_statement : "forindiset" "(" scalar "," scalar "," scalar "," scalar ")" "{" statements "}" { # warn "item is ", ::Dumper \@item; "$item[9] = 0;\n" . "LOOP: for (\@{" . "$item[3]})\n" . "{\n" . " ($item[5], $item[7]) = \@\$_;\n" . " $item[9]++;\n" . ::indent($item[12]) . "}\n" } scalar_assignment : scalar "," { "$item[1] = " } include_statement : "include" "(" expression ")" { "do $item[3]" } global_statement : "global" "(" name ")" { $Globals{$item[3]}++; qq(my \$$item[3]) } set_statement : "set" "(" scalar "," expression ")" { "$item[3] = $item[5]" } getintmsg_statement : "getintmsg" "(" scalar "," expression ")" { ::msg($prevline, $prevcolumn, qq(warning: $item[1] needs to be replaced)); "$item[3] = $item[5]" } getstrmsg_statement : "getstrmsg" "(" scalar "," expression ")" { ::msg($prevline, $prevcolumn, qq(warning: $item[1] needs to be replaced)); "$item[3] = $item[5]" } getindimsg_statement : "getindimsg" "(" scalar "," expression ")" { ::msg($prevline, $prevcolumn, qq(warning: $item[1] needs to be replaced)); "$item[3] = $item[5]" } continue_statement : "continue" "(" ")" { "next LOOP" } break_statement : "break" "(" ")" { "last LOOP" } return_statement : "return" expression(?) { "return" . (@{$item[2]} ? " @{$item[2]}" : "") } list_statement : "list" "(" name ")" { my $s = $item[3]; $Locals{$s}++ unless exists $Globals{$s} || exists $Params{$s}; "\$$s = []" } table_statement : "table" "(" name ")" { my $s = $item[3]; $Locals{$s}++ unless exists $Globals{$s} || exists $Params{$s}; "\$$s = {}" } indiset_statement : "indiset" "(" name ")" { my $s = $item[3]; $Locals{$s}++ unless exists $Globals{$s} || exists $Params{$s}; "\$$s = []" } name : /(?!\d)\w+/ scalar : name { my $s = $item[1]; $Locals{$s}++ unless exists $Globals{$s} || exists $Params{$s}; "\$$s" } scalars : name ("," name)(s?) { $Params{$_}++ for ($item[1], @{$item[2]}); '$' . join ', $', $item[1], @{$item[2]} } #scalars : scalar ("," scalar)(s?) # { # # $Params{$_}++ for ($item[1], @{$item[2]); # join ', ', $item[1], @{$item[2]} # } expressions : expression ("," expression)(s?) { [$item[1], @{$item[2]}] } expressions2 : expression ("," expression)(s) { [$item[1], @{$item[2]}] } _call_statement : name "(" expressions(?) ")" ...!"{" { "&$item[1](" . join(", ", map {@$_} @{$item[3]}) . ")" } non_call_statement : _call_statement { ::msg($prevline, $prevcolumn, qq(warning: $item[1] called without "call")); $item[1] } call_statement : "call" _call_statement builtin_function : add_function | sub_function | mul_function | div_function | mod_function | exp_function | neg_function | and_function | or_function | not_function | eq_function | eqstr_function | ne_function | nestr_function | lt_function | le_function | gt_function | ge_function | empty_function | length_function | dequeue_function | pop_function | getel_function | lookup_function builtin_procedure : incr_procedure | decr_procedure | enqueue_procedure | requeue_procedure | push_procedure | setel_procedure | insert_procedure add_function : "add" "(" expressions2 ")" { "(" . join(" + ", @{$item[3]}) . ")" } sub_function : "sub" "(" expression "," expression ")" { "($item[3] - $item[5])" } mul_function : "mul" "(" expressions2 ")" { "(" . join(" * ", @{$item[3]}) . ")" } div_function : "div" "(" expression "," expression ")" { "($item[3] / $item[5])" } mod_function : "mod" "(" expression "," expression ")" { "($item[3] % $item[5])" } exp_function : "exp" "(" expression "," expression ")" { "($item[3] ** $item[5])" } neg_function : "neg" "(" expression ")" { "(- $item[3])" } and_function : "and" "(" expressions2 ")" { "(" . join(" && ", @{$item[3]}) . ")" } or_function : "or" "(" expressions2 ")" { "(" . join(" || ", @{$item[3]}) . ")" } not_function : "not" "(" expression ")" { "(! $item[3])" } eq_function : "eq" "(" expression "," expression ")" { "($item[3] == $item[5])" } ne_function : "ne" "(" expression "," expression ")" { "($item[3] != $item[5])" } eqstr_function : "eqstr" "(" expression "," expression ")" { "($item[3] eq $item[5])" } nestr_function : "nestr" "(" expression "," expression ")" { "($item[3] ne $item[5])" } lt_function : "lt" "(" expression "," expression ")" { "($item[3] < $item[5])" } le_function : "le" "(" expression "," expression ")" { "($item[3] <= $item[5])" } gt_function : "gt" "(" expression "," expression ")" { "($item[3] > $item[5])" } ge_function : "ge" "(" expression "," expression ")" { "($item[3] >= $item[5])" } empty_function : "empty" "(" name ")" { "(\@\$$item[3] ? 0 : 1)" } length_function : "length" "(" name ")" { "(scalar \@\$$item[3])" } dequeue_function : "dequeue" "(" name ")" { "(shift \@\$$item[3])" } pop_function : "pop" "(" name ")" { "(pop \@\$$item[3])" } getel_function : "getel" "(" name "," expression ")" { "\$$item[3]" . "->[$item[5] - 1]" } lookup_function : "lookup" "(" name "," expression ")" { "\$$item[3]" . "->{$item[5]}" } emulated_function : emulated_name "(" expressions(?) ")" { # warn "item is ", ::Dumper \@item; "&$item[1](" . join(", ", map {@$_} @{$item[3]}) . ")" } incr_procedure : "incr" "(" scalar ")" { "$item[3]++" } decr_procedure : "decr" "(" scalar ")" { "$item[3]--" } enqueue_procedure : "enqueue" "(" name "," expression ")" { "push \@\$$item[3], $item[5]" } requeue_procedure : "requeue" "(" name "," expression ")" { "unshift \@\$$item[3], $item[5]" } push_procedure : "push" "(" name "," expression ")" { "push \@\$$item[3], $item[5]" } setel_procedure : "setel" "(" name "," expression "," expression ")" { "\$$item[3]" . "->[$item[5] - 1] = $item[7]" } insert_procedure : "insert" "(" name "," expression "," expression ")" { "\$$item[3]" . "->{$item[5]} = $item[7]" } constant : /([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?/ | /".*?(?new($Grammar . $x); undef $/; my $input = <>; # print STDERR "input is $input"; $parse->program($input) or die "invalid input"; print < sub { dsys uncompress($src) . " $src | tar xf -" }, dir => sub { $src =~ m|.*/(.*)\.tar\.| && $1 }, config => sub { dsys "$Perl Makefile.PL" }, make => sub { dsys "make" }, test => sub { sys "make test" }, # some modules fail their tests... install => sub { dsys "make install" }, %$opts }; print "build $module\n"; $opts->{"unpack"}->(); my $dir = $opts->{dir}->(); chdir $dir or die "Can't chdir $dir: $!"; $opts->{config}->(); $opts->{make}->(); $opts->{test}->(); $opts->{install}->(); print "built $module\n"; } sub feed ($$) { my ($command, $input) = @_; open COMMAND, "| $command" or die "Cannot run $command:$!\n"; print COMMAND $input; close COMMAND or die "Cannot run $command:$!\n"; } sub main () { dsys "rm -rf $Build"; mkdir $Build, 0750 or die "Can't mkdir $Build: $!"; $ENV{HOME} = $Perl_installation; if (building "perl") { chdir $Build or die "Can't chdir $Build: $!"; dsys "rm -rf $Perl_installation"; dsys uncompress($Perl_src) . " $Perl_src | tar xf -"; chdir $Perl_dir or die "Can't chdir $Perl_dir: $!"; my @opts = ( "-Dperladmin='paul\@pjcj.net'", "-Dprefix=$Perl_installation", "-Dusedevel", ); push @opts, ( "-Dccflags='-fprofile-arcs -ftest-coverage'", "-Dldflags='-fprofile-arcs -ftest-coverage'", "-Doptimize='-g -O0'", ) if building "coverage"; dsys "sh ./Configure -des @opts"; dsys "make"; sys "make test"; dsys "make install"; $Options =~ s/\bperl\b//; } $ENV{PATH} .= ":$Perl_installation/bin"; # dodgy stuff that just calls perl chdir $top or die "Can't chdir $top: $!"; my $restart = "yes '' | $Perl $0 $Src_dir $Perl_src $Installation $Options"; print "<$restart [$^X] [$Perl]>\n"; exec $restart if $^X ne $Perl; # my $apache = "apache_1.3.34"; my $apache = "httpd-2.0.55"; if ($apache =~ /apache/) { my $mod_perl = "mod_perl-1.29"; build $apache, $Src_dir, { config => sub {}, make => sub {}, test => sub {}, install => sub {}, } if building "apache"; build $mod_perl, $Src_dir, { config => sub { dsys "$Perl Makefile.PL" . " APACHE_SRC=../$apache/src" . " DO_HTTPD=1 USE_APACI=1 PREP_HTTPD=1 EVERYTHING=1"; }, } if building "mod_perl"; build $apache, $Src_dir, { "unpack" => sub {}, config => sub { dsys "./configure" . " --prefix=$Installation/$apache" . " --enable-module=so" . " --enable-module=rewrite" . " --activate-module=src/modules/perl/libperl.a"; }, } if building "apache"; } else { my $mod_perl = "mod_perl-2.0.2"; build $apache, $Src_dir, { config => sub { dsys "./configure" . " --prefix=$Installation/$apache"; }, } if building "apache"; build $mod_perl, $Src_dir, { config => sub { dsys "$Perl Makefile.PL" . " MP_APXS=$Installation/$apache/bin/apxs"; }, } if building "mod_perl"; } if (building "modules") { my @first = qw( ); my @last = qw( Data::Dump::Streamer ); my @manual = qw( Apache::Compress Apache::Filter ); my @modules = qw( LWP Module::Build Pod::Coverage Date::Calc Apache::Clean Apache::Request Apache::Session Apache::Test Image::Size Template HTML::Lint Date::Manip Parse::RecDescent Roman JSON Test::JSON Test::WWW::Mechanize Devel::Cover B::Utils Data::Dump::Streamer ); my @not_so_hot = qw( ); my $config = { LWP => { test => sub {} }, "Apache::Compress" => { test => sub {} }, "Apache::Filter" => { test => sub {} }, "Apache::Request" => { test => sub {} }, "Apache::TEST" => { test => sub {} }, "Data::Dump::Streamer" => { config => sub { dsys "$Perl Makefile.PL DDS" } }, }; my $f = "$Perl_installation/.cpan"; -d $f or mkdir $f, 0750 or die "Can't mkdir $f: $!"; $f.= "/CPAN"; -d $f or mkdir $f, 0750 or die "Can't mkdir $f: $!"; $f.= "/MyConfig.pm"; open F, ">", $f or die "Can't open $f: $!"; print F < q[100000], 'build_dir' => q[$Perl_installation/.cpan/build], 'cache_metadata' => q[1], 'cpan_home' => q[$Perl_installation/.cpan], 'dontload_hash' => { }, 'ftp' => q[/usr/bin/ftp], 'ftp_proxy' => q[], 'getcwd' => q[cwd], 'gpg' => q[/usr/bin/gpg], 'gzip' => q[/bin/gzip], 'histfile' => q[$Perl_installation/.cpan/histfile], 'histsize' => q[100], 'http_proxy' => q[], 'inactivity_timeout' => q[0], 'index_expire' => q[1], 'inhibit_startup_message' => q[0], 'keep_source_where' => q[$Perl_installation/.cpan_sources], 'lynx' => q[/usr/bin/lynx], 'make' => q[/usr/bin/make], 'make_arg' => q[], 'make_install_arg' => q[], 'makepl_arg' => q[], 'ncftp' => q[], 'ncftpget' => q[], 'no_proxy' => q[], 'pager' => q[less], 'prerequisites_policy' => q[follow], 'scan_cache' => q[atstart], 'shell' => q[/bin/zsh], 'tar' => q[/bin/tar], 'term_is_latin' => q[1], 'unzip' => q[/usr/bin/unzip], 'urllist' => [q[ftp://ftp.demon.co.uk/pub/CPAN/], q[ftp://ftp.mirrorservice.org/sites/ftp.funet.fi/pub/languages/perl/CPAN/], q[ftp://usit.shef.ac.uk/pub/packages/CPAN/], q[ftp://ftp.funet.fi/pub/languages/perl/CPAN/]], 'wget' => q[/usr/bin/wget], }; 1; EOF close F or die "Can't close $f: $!"; $ENV{APXS} = "$Installation/$apache/bin/apxs"; eval "use CPAN"; my $install = sub { my ($m) = @_; print "Installing $m via CPAN\n"; # I wish I knew how to do this properly. I just want to # force install the thing. my $mod = CPAN::Shell->expandany($m); if ($mod) { return if $mod->uptodate; # $mod->force("install"); CPAN::Shell->force("install", $_); } else { CPAN::Shell->force("install", $_); # CPAN::Shell->install($_); } # CPAN::Shell->expandany($_)->install; }; # $install->($_) for @first; $install->($_) for @modules; for my $mod (@last) { # my @mods = CPAN::Complete::cpl_any($mod); # print "Mods for $mod are: @mods\n"; # next; print "Installing $mod \n"; next unless building "manual"; my $m = CPAN::Shell->expandany($mod); print "Getting version ", $m->cpan_version, "\n"; $m->get; my $b = $m->cpan_file; $b =~ s|.*/||; $b =~ s|\.tar.gz||; $b = "$Perl_installation/.cpan/build/$b"; die "Can't find build dir $b" unless -d $b; # use Data::Dumper; print Dumper $m; print "Building in $b\n"; my $c = { %{$config->{$mod} || {}}, unpack => sub {}, dir => sub { $b }, # make => sub {}, # test => sub {}, # install => sub { $m->install }, # install => sub { $m->install; dsys "make test install" }, }; build $mod, $b, $c; } } } $Perl_src = get_src($Perl_src, $Src_dir); ($Perl_dir) = $Perl_src =~ m!.*/(.*)\.tar\.(gz|bz2)$!; print "perl src is $Perl_src\n"; print "perl dir is $Perl_dir\n"; $Perl_installation .= "$Installation/$Perl_dir"; $Perl = "$Perl_installation/bin/perl"; $Perl = <${Perl}5*> unless -e $Perl; die "Can't find perl under $Perl_installation" unless -e $Perl; main Gedcom-1.19/install/SETUP0000644000175000017500000000106312204002473013563 0ustar pjcjpjcjBuild perl, apache, mod_perl and the required modules: Download perl, apache and mod_perl into /src/dir Build everything: $ cd install $ perl ./buildperl /src/dir perl-5.8.5 /usr/local/pkg/gedcom-1 Change /src/dir, perl-5.8.5, /usr/local/pkg/gedcom-1 to the location of your downloaded source tarballs, the version of perl you will be installing and the location to which the packages will be installed respectively. Run tests: $ make test Start the server: $ make restart Stop the server: $ make stop Gedcom-1.19/install/System.pm0000644000175000017500000000344512204002473014570 0ustar pjcjpjcj# Copyright 1999-2012 by Paul Johnson (paul@pjcj.net) # documentation at __END__ # Original author: Paul Johnson # Created: Fri 12 Mar 1999 10:25:51 am use strict; require 5.004; package System; use Exporter (); use vars qw($VERSION @ISA @EXPORT); $VERSION = do { my @r = (q$Revision: 1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker @ISA = ("Exporter"); @EXPORT = ("sys", "dsys"); my $Command = 0; my $Errors = 0; my $Verbose = 0; sub import { my $class = shift; my $args = "@_"; $Command = $args =~ /\bcommand\b/i; $Errors = $args =~ /\berror\b/i; $Verbose = $args =~ /\bverbose\b/i; $Command ||= $Verbose; $Errors ||= $Verbose; $class->export_to_level(1, "sys" ) if $args =~ /\bsys\b/i; $class->export_to_level(1, "dsys") if $args =~ /\bdsys\b/i; } sub sys { my (@command) = @_; local $| = 1; print "@command" if $Command; my $rc = 0xffff & system @command; print "\n" if $Command && !$rc && !$Verbose; ret($rc); } sub dsys { die "@_ failed" if sys @_; } sub ret { my ($rc) = @_; printf " returned %#04x: ", $rc if $Errors && $rc; if ($rc == 0) { print "ran with normal exit\n" if $Verbose; } elsif ($rc == 0xff00) { print "command failed: $!\n" if $Errors; } elsif ($rc > 0x80) { $rc >>= 8; print "ran with non-zero exit status $rc\n" if $Errors; } else { print "ran with " if $Errors; if ($rc & 0x80) { $rc &= ~0x80; print "coredump from " if $Errors; } print "signal $rc\n" if $Errors; } $rc; } 1 __END__ =head1 NAME System - run a system command and check the result =head1 SYNOPSIS use System "command, verbose, errors"; sys qw(ls -al); =head1 DESCRIPTION The sys function runs a system command, checks result, and comments on it. =cut Gedcom-1.19/parse_grammar0000755000175000017500000000456312204002474014051 0ustar pjcjpjcj#!/usr/local/bin/perl -w # Copyright 1998-2013, Paul Johnson (paul@pjcj.net) # 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.19 - 18th August 2013 use strict; require 5.005; use Data::Dumper; use Gedcom; use vars qw( $VERSION ); $VERSION = "1.19"; $SIG{__WARN__} = sub { print "\n@_" }; sub main() { die "usage: $0 grammar_file [version]\n" unless @ARGV == 1 || @ARGV == 2; my ($grammar_file, $version) = @ARGV; ($version) = $grammar_file =~ /(\d+(\.\d+)*)/ unless defined $version; die "version must be a gedcom version number\n" unless $version; $| = 1; print "reading $grammar_file ..."; my $grammar = Gedcom::Grammar->new(file => $grammar_file, version => $version, callback => sub { print "." }); delete $grammar->{callback}; delete $grammar->{stored_record}; 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 $v = $version) =~ tr/./_/; my $g = "Grammar_$v"; my $gpm = "lib/Gedcom/$g.pm"; print "\nwriting $gpm ...\n"; open(G, ">$gpm") or die "Can't open $gpm: $!"; print G <new([$grammar], ["grammar"]); $d->Indent(1)->Purity(1)->Quotekeys(0); my $dv = eval $Data::Dumper::VERSION; $d->Sortkeys(1) if $dv >= 2.12; $d->Useperl(1) if $dv >= 2.12; # Because of a bug. print G $d->Dump; close G or die "Can't open $gpm: $!"; } main; Gedcom-1.19/royal.ged0000644000175000017500000006031412204002474013106 0ustar pjcjpjcj0 HEAD 1 SOUR PAF 2.2 2 VERS 2.2 1 DEST PAF 1 DATE Friday, 20th November 1992 1 FILE ROYALS.GED 1 CHAR ANSEL 1 GEDC 2 VERS 5.5 2 FORM LINEAGE-LINKED 1 SUBM @SUBM1@ 1 NOTE This Gedcom file should only be used as part of the testsuite 2 CONC for Gedcom.pm (http://www.pjcj.net). I have removed a 2 CONC lot of data from the original, and changed a few bits, so you 2 CONC should use the original if you want royal genealogy. Contact me 2 CONC if you cannot locate the original. 2 CONC 2 CONC Paul Johnson (paul@pjcj.net) 2 CONC 2 CONC >> In a message to Cliff Manis (cmanis@csoftec.csf.com) 2 CONC >> Denis Reid wrote the following: 2 CONC >> Date: Fri, 25 Dec 92 14:12:32 -0500 2 CONC >> From: ah189@cleveland.Freenet.Edu (Denis Reid) 2 CONC >> Subject: THE ROYALS 2 CONC >> First of all, MERRY CHRISTMAS! 2 CONC >> 2 CONC >> You may make this Royal GEDCOM available available to whomever. 2 CONC >> As you know this is a work in process and have received 2 CONC >> suggestions, corrections and additions from all over the planet... 2 CONC >> some even who claim to be descended from Charlemange, himself! 2 CONC >> 2 CONC >> The weakest part of the Royals is in the French and Spanish lines. 2 CONC >> I found that many of the French Kings had multiple mistresses 2 CONC >> whose descendants claimed noble titles, and the Throne itself in 2 CONC >> some cases. I have had the hardest time finding good published 2 CONC >> sources for French and Spanish Royalty. 2 CONC >> 2 CONC >> If you do post it to a BBS or send it around, I would appreciate 2 CONC >> it if you'd append a message to the effect that I would welcome 2 CONC >> comments and suggestions and possible sources to improve the 2 CONC >> database. 2 CONC >> 2 CONC >> Since the Royals had so many names and many titles it was 2 CONC >> difficult to "fill in the blanks" with their name. In the 2 CONC >> previous version, I included all their titles, names, monikers in 2 CONC >> the notes. 2 CONC >> 2 CONC >> Thanks for your interest. Denis Reid 0 @SUBM1@ SUBM 1 NAME Denis R. Reid 1 ADDR 149 Kimrose Lane 2 CONT Broadview Heights, Ohio 44147-1258 2 CONT Internet Email address: ah189@cleveland.freenet.edu 1 PHON (216) 237-5364 1 RIN 1 0 @I1@ INDI 1 NAME Edward_VII /Wettin/ 1 TITL King of England 1 SEX M 1 BIRT 2 DATE Tuesday, 9th November 1841 2 PLAC Buckingham,Palace,London,England 1 DEAT 2 DATE Friday, 6th May 1910 2 PLAC Buckingham,Palace,London,England 1 BURI 2 DATE Friday, 20th May 1910 2 PLAC Windsor,Berkshire,England 1 FAMS @F2@ 1 FAMC @F1@ 1 RIN 2 0 @I2@ INDI 1 NAME Alexandra of_Denmark "Alix"// 1 TITL Princess 1 SEX F 1 BIRT 2 DATE Sunday, 1st December 1844 2 PLAC Yellow Palace,Copenhagen,Denmark 1 DEAT 2 DATE Friday, 20th November 1925 2 PLAC Sandringham,,Norfolk,England 1 BURI 2 PLAC St. George Chap.,Windsor,Berkshire,England 1 FAMS @F2@ 1 FAMC @F24@ 1 RIN 3 0 @I3@ INDI 1 NAME George_V /Windsor/ 1 TITL King of England 1 SEX M 1 BIRT 2 DATE Saturday, 3rd June 1865 2 PLAC Marlborough Hse,London,England 1 CHR 2 DATE Friday, 7th July 1865 1 DEAT 2 DATE Monday, 20th January 1936 2 PLAC Sandringham,Norfolk,England 1 BURI 2 DATE Tuesday, 28th January 1936 2 PLAC Windsor Castle,St. George Chap.,Berkshire,England 1 FAMS @F3@ 1 FAMC @F2@ 1 RIN 4 0 @I4@ INDI 1 NAME Mary_of_Teck (May) // 1 TITL Queen 1 SEX F 1 BIRT 2 DATE Sunday, 26th May 1867 2 PLAC Kensington,Palace,London,England 1 DEAT 2 DATE Tuesday, 24th March 1953 2 PLAC Marlborough Hse,London,England 1 BURI 2 DATE Tuesday, 31st March 1953 2 PLAC St. George's,Chapel,Windsor Castle,England 1 FAMS @F3@ 1 FAMC @F19@ 1 RIN 5 0 @I5@ INDI 1 NAME Edward_VIII /Windsor/ 1 TITL Duke of Windsor 1 SEX M 1 BIRT 2 DATE Saturday, 23rd June 1894 2 PLAC White Lodge,Richmond Park,Surrey,England 1 DEAT 2 DATE Sunday, 28th May 1972 2 PLAC Paris,,,France 1 BURI 2 PLAC Frogmore,Windsor,Berkshire,England 1 FAMS @F12@ 1 FAMC @F3@ 1 RIN 6 0 @I6@ INDI 1 NAME Bessiewallis /Warfield/ 1 SEX F 1 BIRT 2 DATE 1896 2 PLAC ,,,U.S.A. 1 DEAT 2 DATE Thursday, 24th April 1986 2 PLAC Paris,,,France 1 BURI 2 PLAC Frogmore,Windsor,Berkshire,England 1 FAMS @F12@ 1 FAMS @F14@ 1 FAMS @F15@ 1 FAMC @F23@ 1 RIN 7 0 @I7@ INDI 1 NAME George_VI /Windsor/ 1 TITL King of England 1 SEX M 1 BIRT 2 DATE Saturday, 14th December 1895 2 PLAC York Cottage,Sandringham,Norfolk,England 1 DEAT 2 DATE Wednesday, 6th February 1952 2 PLAC Sandringham,Norfolk,England 1 BURI 2 DATE Tuesday, 11th March 1952 2 PLAC St. George Chap.,,Windsor,England 1 FAMS @F4@ 1 FAMC @F3@ 1 RIN 8 0 @I8@ INDI 1 NAME Elizabeth Angela Marguerite/Bowes-Lyon/ 1 TITL Lady 1 SEX F 1 BIRT 2 DATE Saturday, 4th August 1900 2 PLAC ,,London,England 1 CHR 2 DATE Sunday, 23rd September 1900 1 FAMS @F4@ 1 FAMC @F20@ 1 RIN 9 0 @I9@ INDI 1 NAME Elizabeth_II Alexandra Mary/Windsor/ 1 TITL Queen of England 1 SEX F 1 BIRT 2 DATE Wednesday, 21st April 1926 2 PLAC 17 Bruton St.,London,W1,England 1 FAMS @F6@ 1 FAMC @F4@ 1 RIN 10 0 @I10@ INDI 1 NAME Philip /Mountbatten/ 1 TITL Prince 1 SEX M 1 BIRT 2 DATE Friday, 10th June 1921 2 PLAC Isle of Kerkira,Mon Repos,Corfu,Greece 1 FAMS @F6@ 1 FAMC @F16@ 1 RIN 11 0 @I11@ INDI 1 NAME Charles Philip Arthur/Windsor/ 1 TITL Prince 1 SEX M 1 BIRT 2 DATE Sunday, 14th November 1948 2 PLAC Buckingham,Palace,London,England 1 CHR 2 DATE Wednesday, 15th December 1948 2 PLAC Buckingham,Palace,Music Room,England 1 FAMS @F8@ 1 FAMC @F6@ 1 RIN 12 0 @I12@ INDI 1 NAME Diana Frances /Spencer/ 1 TITL Lady 1 SEX F 1 BIRT 2 DATE Saturday, 1st July 1961 2 PLAC Park House,Sandringham,Norfolk,England 1 CHR 2 PLAC Sandringham,Church,Norfolk,England 1 FAMS @F8@ 1 FAMC @F26@ 1 RIN 13 0 @I13@ INDI 1 NAME William Arthur Philip/Windsor/ 1 TITL Prince 1 SEX M 1 BIRT 2 DATE Monday, 21st June 1982 2 PLAC St. Mary's Hosp.,Paddington,London,England 1 CHR 2 DATE Wednesday, 4th August 1982 2 PLAC Music Room,Buckingham,Palace,England 1 FAMC @F8@ 1 RIN 14 0 @I14@ INDI 1 NAME Henry Charles Albert/Windsor/ 1 TITL Prince 1 SEX M 1 BIRT 2 DATE Saturday, 15th September 1984 2 PLAC St. Mary's Hosp.,Paddington,London,England 1 FAMC @F8@ 1 RIN 15 0 @I15@ INDI 1 NAME Anne Elizabeth Alice/Windsor/ 1 TITL Princess 1 SEX F 1 BIRT 2 DATE Tuesday, 15th August 1950 2 PLAC Clarence House,St. James,,England 1 CHR 2 DATE Saturday, 21st October 1950 2 PLAC ,,,England 1 FAMS @F7@ 1 FAMC @F6@ 1 RIN 16 0 @I16@ INDI 1 NAME Mark Anthony Peter/Phillips/ 1 TITL Captain 1 SEX M 1 BIRT 2 DATE Wednesday, 22nd September 1948 1 FAMS @F7@ 1 FAMC @F40@ 1 RIN 17 0 @I17@ INDI 1 NAME Peter Mark Andrew/Phillips/ 1 SEX M 1 BIRT 2 DATE Tuesday, 15th November 1977 2 PLAC St. Mary's Hosp.,Paddington,London,England 1 CHR 2 DATE Thursday, 22nd December 1977 2 PLAC Music Room,Buckingham,Palace,England 1 FAMC @F7@ 1 RIN 18 0 @I18@ INDI 1 NAME Zara Anne Elizabeth/Phillips/ 1 SEX F 1 BIRT 2 DATE Friday, 15th May 1981 2 PLAC St. Marys Hosp.,Paddington,London,England 1 FAMC @F7@ 1 RIN 19 0 @I19@ INDI 1 NAME Andrew Albert Christian/Windsor/ 1 TITL Duke of York 1 SEX M 1 BIRT 2 DATE Friday, 19th February 1960 2 PLAC Belgian Suite,Buckingham,Palace,England 1 FAMS @F21@ 1 FAMC @F6@ 1 RIN 20 0 @I20@ INDI 1 NAME Sarah Margaret /Ferguson/ 1 TITL Duchess of York 1 SEX F 1 BIRT 2 DATE Thursday, 15th October 1959 2 PLAC 27 Welbech St.,Marylebone,London,England 1 FAMS @F21@ 1 FAMC @F22@ 1 RIN 21 0 @I21@ INDI 1 NAME Beatrice Elizabeth Mary/Windsor/ 1 TITL Princess 1 SEX F 1 BIRT 2 DATE Monday, 8th August 1988 2 PLAC Portland Hosp.,,England 1 FAMC @F21@ 1 RIN 22 0 @I22@ INDI 1 NAME Eugenie Victoria Helena/Windsor/ 1 TITL Princess 1 SEX F 1 BIRT 2 DATE Friday, 23rd March 1990 2 PLAC London,England 1 CHR 2 DATE Sunday, 23rd December 1990 2 PLAC Sandringham,England 1 FAMC @F21@ 1 RIN 23 0 @I23@ INDI 1 NAME Edward Anthony Richard/Windsor/ 1 TITL Prince 1 SEX M 1 BIRT 2 DATE Tuesday, 10th March 1964 2 PLAC Buckingham,Palace,London,England 1 CHR 2 DATE Saturday, 2nd May 1964 1 FAMC @F6@ 1 RIN 24 0 @I24@ INDI 1 NAME Margaret Rose /Windsor/ 1 TITL Princess 1 SEX F 1 BIRT 2 DATE Thursday, 21st August 1930 2 PLAC Glamis Castle,,Angus,Scotland 1 FAMS @F5@ 1 FAMC @F4@ 1 RIN 25 0 @I25@ INDI 1 NAME Anthony Charles Robert/Armstrong-Jones/ 1 TITL Earl of Snowdon 1 SEX M 1 BIRT 2 DATE Friday, 7th March 1930 1 FAMS @F5@ 1 FAMS @F44@ 1 RIN 26 0 @I26@ INDI 1 NAME David Albert Charles/Armstrong-Jones/ 1 TITL Vicount Linley 1 SEX M 1 BIRT 2 DATE Friday, 3rd November 1961 1 FAMC @F5@ 1 RIN 27 0 @I27@ INDI 1 NAME Sarah Frances Elizabeth/Armstrong-Jones/ 1 TITL Lady 1 SEX F 1 BIRT 2 DATE Friday, 1st May 1964 1 FAMC @F5@ 1 RIN 28 0 @I28@ INDI 1 NAME Mary /Windsor/ 1 TITL Princess Royal 1 SEX F 1 BIRT 2 DATE Sunday, 25th April 1897 2 PLAC York Cottage,Sandringham,Norfolk,England 1 DEAT 2 DATE Sunday, 28th March 1965 2 PLAC Harewood House,Yorkshire,,England 1 FAMS @F10@ 1 FAMC @F3@ 1 RIN 29 0 @I29@ INDI 1 NAME Henry George Charles/Lascelles/ 1 TITL Viscount 1 SEX M 1 BIRT 2 DATE 1882 1 DEAT 2 DATE 1947 1 FAMS @F10@ 1 RIN 30 0 @I30@ INDI 1 NAME George Earl_of_Harewood /Lascelles/ 1 TITL Viscount 1 SEX M 1 BIRT 2 DATE 1923 1 FAMS @F27@ 1 FAMS @F29@ 1 FAMC @F10@ 1 RIN 31 0 @I31@ INDI 1 NAME Marion (Maria) Donata/Stein/ 1 TITL Countess 1 SEX F 1 BIRT 2 DATE 1926 1 FAMS @F27@ 1 FAMC @F47@ 1 RIN 32 0 @I32@ INDI 1 NAME David /Lascelles/ 1 TITL Viscount 1 SEX M 1 BIRT 2 DATE 1950 1 FAMS @F34@ 1 FAMC @F27@ 1 RIN 33 0 @I33@ INDI 1 NAME Margaret /Messenger/ 1 SEX F 1 FAMS @F34@ 1 RIN 34 0 @I34@ INDI 1 NAME Emily // 1 TITL Hon. 1 SEX F 1 BIRT 2 DATE 1976 1 FAMC @F34@ 1 RIN 35 0 @I35@ INDI 1 NAME Benjamin // 1 TITL Hon. 1 SEX M 1 BIRT 2 DATE 1978 1 FAMC @F34@ 1 RIN 36 0 @I36@ INDI 1 NAME Alexander /Lascelles/ 1 TITL Hon. 1 SEX M 1 BIRT 2 DATE 1980 1 FAMC @F34@ 1 RIN 37 0 @I37@ INDI 1 NAME Edward /Lascelles/ 1 SEX M 1 BIRT 2 DATE 1982 1 FAMC @F34@ 1 RIN 38 0 @I38@ INDI 1 NAME James /Lascelles/ 1 TITL Hon. 1 SEX M 1 BIRT 2 DATE 1953 1 FAMS @F35@ 1 FAMC @F27@ 1 RIN 39 0 @I39@ INDI 1 NAME Fredericka Ann /Duhrrson/ 1 SEX F 1 FAMS @F35@ 1 RIN 40 0 @I40@ INDI 1 NAME Sophie /Lascelles/ 1 SEX F 1 BIRT 2 DATE 1973 1 FAMC @F35@ 1 RIN 41 0 @I41@ INDI 1 NAME Rowan /Lascelles/ 1 SEX M 1 BIRT 2 DATE 1977 1 FAMC @F35@ 1 RIN 42 0 @I42@ INDI 1 NAME Jeremy /Lascelles/ 1 TITL Hon. 1 SEX M 1 BIRT 2 DATE 1955 1 FAMS @F36@ 1 FAMC @F27@ 1 RIN 43 0 @I43@ INDI 1 NAME Julie /Bayliss/ 1 SEX F 1 FAMS @F36@ 1 RIN 44 0 @I44@ INDI 1 NAME Thomas /Lascelles/ 1 SEX M 1 BIRT 2 DATE 1982 1 FAMC @F36@ 1 RIN 45 0 @I45@ INDI 1 NAME Ellen /Lascelles/ 1 SEX F 1 BIRT 2 DATE 1984 1 FAMC @F36@ 1 RIN 46 0 @I46@ INDI 1 NAME Patricia /Tuckwell/ 1 SEX F 1 BIRT 2 DATE 1923 1 FAMS @F29@ 1 FAMS @F46@ 1 RIN 47 0 @I47@ INDI 1 NAME Mark /Lascelles/ 1 TITL Hon. 1 SEX M 1 BIRT 2 DATE 1964 1 FAMC @F29@ 1 RIN 48 0 @I48@ INDI 1 NAME Gerald /Lascelles/ 1 TITL Hon. 1 SEX M 1 BIRT 2 DATE 1924 1 FAMS @F28@ 1 FAMS @F30@ 1 FAMC @F10@ 1 RIN 49 0 @I49@ INDI 1 NAME Angela /Dowding/ 1 SEX F 1 BIRT 2 DATE 1919 1 FAMS @F28@ 1 RIN 50 0 @I50@ INDI 1 NAME Henry /Lascelles/ 1 SEX M 1 BIRT 2 DATE 1953 1 FAMS @F38@ 1 FAMC @F28@ 1 RIN 51 0 @I51@ INDI 1 NAME Alexandra /Morton/ 1 SEX F 1 FAMS @F38@ 1 RIN 52 0 @I52@ INDI 1 NAME Elizabeth Collingwood /Colvin/ 1 SEX F 1 BIRT 2 DATE 1924 1 FAMS @F30@ 1 RIN 53 0 @I53@ INDI 1 NAME Martin /Lascelles/ 1 SEX M 1 BIRT 2 DATE 1963 1 FAMC @F30@ 1 RIN 54 0 @I54@ INDI 1 NAME Henry William Frederick/Windsor/ 1 TITL Duke 1 SEX M 1 BIRT 2 DATE Saturday, 31st March 1900 2 PLAC York Cottage,Sandringham,Norfolk,England 1 DEAT 2 DATE 1974 1 FAMS @F11@ 1 FAMC @F3@ 1 RIN 55 0 @I55@ INDI 1 NAME Alice Christabel /Montagu-Douglas/ 1 TITL Lady 1 SEX F 1 BIRT 2 DATE Wednesday, 25th December 1901 2 PLAC London,England 1 FAMS @F11@ 1 FAMC @F33@ 1 RIN 56 0 @I56@ INDI 1 NAME William Henry Andrew/Windsor/ 1 TITL Prince 1 SEX M 1 BIRT 2 DATE Thursday, 18th December 1941 2 PLAC Hadley Common,Hertfordshire,England 1 CHR 2 DATE Sunday, 22nd February 1942 2 PLAC Private Chapel,Windsor Castle,Berkshire,England 1 DEAT 2 DATE Monday, 28th August 1972 2 PLAC Near,Wolverhampton,England 1 FAMC @F11@ 1 RIN 57 0 @I57@ INDI 1 NAME Richard Alexander Walter/Windsor/ 1 TITL Prince 1 SEX M 1 BIRT 2 DATE Saturday, 26th August 1944 2 PLAC Hadley Common,Hertfordshire,England 1 CHR 2 DATE Friday, 20th October 1944 2 PLAC Private Chapel,Windsor Castle,Berkshire,England 1 FAMS @F13@ 1 FAMC @F11@ 1 RIN 58 0 @I58@ INDI 1 NAME Birgitte of_Denmark /von_Deurs/ 1 TITL Duchess 1 SEX F 1 BIRT 2 DATE 1947 1 FAMS @F13@ 1 RIN 59 0 @I59@ INDI 1 NAME Alexander Patrick Gregers// 1 TITL Earl of Ulster 1 SEX M 1 BIRT 2 DATE Thursday, 24th October 1974 2 PLAC St. Marys Hosp.,Paddington,London,England 1 CHR 2 DATE Sunday, 9th February 1975 2 PLAC Barnwell Church 1 FAMC @F13@ 1 RIN 60 0 @I60@ INDI 1 NAME Davina Elizabeth Alice/Windsor/ 1 TITL Lady 1 SEX F 1 BIRT 2 DATE Saturday, 19th November 1977 1 CHR 2 PLAC Barnwell Church,,England 1 FAMC @F13@ 1 RIN 61 0 @I61@ INDI 1 NAME Rose Victoria Birgitte/Windsor/ 1 TITL Lady 1 SEX F 1 BIRT 2 DATE Saturday, 1st March 1980 2 PLAC St. Marys Hosp.,Paddington,England 1 CHR 2 DATE Sunday, 13th July 1980 2 PLAC Barnwell Church,,England 1 FAMC @F13@ 1 RIN 62 0 @I62@ INDI 1 NAME George Edward Alexander/Windsor/ 1 TITL Duke of Kent 1 SEX M 1 BIRT 2 DATE Saturday, 20th December 1902 2 PLAC York Cottage,Sandringham,Norfolk,England 1 DEAT 2 DATE Tuesday, 25th August 1942 2 PLAC Morven,,,Scotland 1 FAMS @F9@ 1 FAMC @F3@ 1 RIN 63 0 @I63@ INDI 1 NAME Marina of_Greece // 1 TITL Princess 1 SEX F 1 BIRT 2 DATE Friday, 30th November 1906 2 PLAC Athens,Greece 1 DEAT 2 DATE 1968 2 PLAC Kensington,Palace,,England 1 FAMS @F9@ 1 FAMC @F25@ 1 RIN 64 0 @I64@ INDI 1 NAME Edward George Nicholas/Windsor/ 1 TITL Duke of Kent 1 SEX M 1 BIRT 2 DATE Monday, 9th September 1935 2 PLAC 3 Belgrave Sq.,,England 1 FAMS @F18@ 1 FAMC @F9@ 1 RIN 65 0 @I65@ INDI 1 NAME Katharine /Worsley/ 1 TITL Duchess of Kent 1 SEX F 1 BIRT 2 DATE 1933 1 FAMS @F18@ 1 FAMC @F37@ 1 RIN 66 0 @I66@ INDI 1 NAME George Philip of_St._Andrews/Windsor/ 1 TITL Earl 1 SEX M 1 BIRT 2 DATE Tuesday, 26th June 1962 1 CHR 2 DATE Friday, 14th September 1962 2 PLAC Buckingham,Palace,Music Room,England 1 FAMS @F41@ 1 FAMC @F18@ 1 RIN 67 0 @I67@ INDI 1 NAME Sylvana /Tomaselli/ 1 SEX F 1 BIRT 2 DATE ABT 1957 2 PLAC Canada 1 FAMS @F42@ 1 FAMS @F41@ 1 FAMC @F43@ 1 RIN 68 0 @I68@ INDI 1 NAME Helen Marina Lucy/Windsor/ 1 TITL Lady 1 SEX F 1 BIRT 2 DATE Tuesday, 28th April 1964 1 CHR 2 DATE Tuesday, 12th May 1964 2 PLAC Private Chapel,Windsor Castle,Berkshire,England 1 FAMC @F18@ 1 RIN 69 0 @I69@ INDI 1 NAME Nicholas Charles Edward/Windsor/ 1 TITL Lord 1 SEX M 1 BIRT 2 DATE Saturday, 25th July 1970 2 PLAC Kings College,Hospital,Denmark Hill 1 CHR 2 PLAC Private Chapel,Windsor Castle,Berkshire,England 1 FAMC @F18@ 1 RIN 70 0 @I70@ INDI 1 NAME Alexandra /Windsor/ 1 TITL Princess 1 SEX F 1 BIRT 2 DATE Friday, 25th December 1936 1 FAMS @F17@ 1 FAMC @F9@ 1 RIN 71 0 @I71@ INDI 1 NAME Angus /Ogilvy/ 1 TITL Hon. 1 SEX M 1 BIRT 2 DATE 1928 1 FAMS @F17@ 1 RIN 72 0 @I72@ INDI 1 NAME James Robert Bruce/Ogilvy/ 1 SEX M 1 BIRT 2 DATE Saturday, 29th February 1964 2 PLAC Thatched House,Lodge,,England 1 FAMS @F45@ 1 FAMC @F17@ 1 RIN 73 0 @I73@ INDI 1 NAME Julia /Rawlinson/ 1 SEX F 1 FAMS @F45@ 1 RIN 74 0 @I74@ INDI 1 NAME Marina Victoria Alexandra/Ogilvy/ 1 SEX F 1 BIRT 2 DATE Sunday, 31st July 1966 2 PLAC Thatched House,Lodge,Richmond Park,England 1 FAMS @F39@ 1 FAMC @F17@ 1 RIN 75 0 @I75@ INDI 1 NAME Paul /Mowatt/ 1 SEX M 1 BIRT 2 DATE ABT 1962 1 FAMS @F39@ 1 RIN 76 0 @I76@ INDI 1 NAME /Mowatt/ 1 SEX F 1 BIRT 2 DATE Saturday, 26th May 1990 1 FAMC @F39@ 1 RIN 77 0 @I77@ INDI 1 NAME Michael /Windsor/ 1 TITL Prince 1 SEX M 1 BIRT 2 DATE Saturday, 4th July 1942 2 PLAC Coppins,,England 1 FAMS @F31@ 1 FAMC @F9@ 1 RIN 78 0 @I78@ INDI 1 NAME Marie-Christine /von_Reibnitz/ 1 TITL Baroness 1 SEX F 1 BIRT 2 DATE Monday, 15th January 1945 2 PLAC Czechoslovakia 1 FAMS @F32@ 1 FAMS @F31@ 1 RIN 79 0 @I79@ INDI 1 NAME Frederick /Windsor/ 1 TITL Lord 1 SEX M 1 BIRT 2 DATE Friday, 6th April 1979 2 PLAC St. Mary's Hosp.,Paddington,London,England 1 CHR 2 DATE Wednesday, 11th July 1979 2 PLAC Chapel Royal,St. James Palace,England 1 FAMC @F31@ 1 RIN 80 0 @I80@ INDI 1 NAME Gabriella Marina Alexandra/Windsor/ 1 TITL Lady 1 SEX F 1 BIRT 2 DATE Thursday, 23rd April 1981 2 PLAC ,,England 1 CHR 2 DATE Monday, 8th June 1981 2 PLAC Chapel Royal,St. James Palace,England 1 FAMC @F31@ 1 RIN 81 0 @I81@ INDI 1 NAME John Charles Francis/Windsor/ 1 TITL Prince 1 SEX M 1 BIRT 2 DATE Wednesday, 12th July 1905 2 PLAC York Cottage,Sandringham,Norfolk,England 1 DEAT 2 DATE Saturday, 18th January 1919 2 PLAC Wood Farm,Wolferton,Norfolk,England 1 BURI 2 PLAC Sandringham,Norfolk,,England 1 FAMC @F3@ 1 RIN 82 0 @I82@ INDI 1 NAME B1 C1 1 BIRT 2 DATE Saturday, 1st January 2000 2 AGE 0 1 BIRT 2 DATE Sunday, 2nd January 2000 1 RIN 83 1 NOTE Line 1 2 CONT Line 2 2 CONT Lin 2 CONC e 3 2 CONT Line 2 CONC 4 0 @I83@ INDI 1 NAME A2 B2 C2 1 NOTE @N1@ 1 RIN 84 0 @I84@ INDI 1 NAME B2 C2 D2 1 RIN 85 0 @I85@ INDI 1 NAME A2 B2 C2 D2 1 RIN 86 0 @I86@ INDI 1 NAME A3B3 C3 D3 1 RIN 87 0 @I87@ INDI 1 NAME A3 B3 C3D3 1 RIN 88 0 @I88@ INDI 1 NAME A3B3 C3D3 1 RIN 89 0 @I89@ INDI 1 NAME a3b3 c3d3 1 RIN 90 0 @I90@ INDI 1 NAME A4B4C4D4 1 RIN 91 0 @I91@ INDI 1 NAME a4b4c4d4 1 RIN 92 0 @F1@ FAM 1 CHIL @I1@ 1 DIV N 1 MARR 2 DATE Monday, 10th February 1840 2 PLAC Chapel Royal,St. James Palace,England 1 RIN 93 0 @F2@ FAM 1 HUSB @I1@ 1 WIFE @I2@ 1 CHIL @I3@ 1 MARR 2 DATE Tuesday, 10th March 1863 2 PLAC St. George Chap.,Windsor,,England 1 RIN 94 0 @F3@ FAM 1 HUSB @I3@ 1 WIFE @I4@ 1 CHIL @I5@ 1 CHIL @I7@ 1 CHIL @I28@ 1 CHIL @I54@ 1 CHIL @I62@ 1 CHIL @I81@ 1 MARR 2 DATE Thursday, 6th July 1893 2 PLAC Chapel Royal,St. James Palace 1 RIN 95 0 @F4@ FAM 1 HUSB @I7@ 1 WIFE @I8@ 1 CHIL @I9@ 1 CHIL @I24@ 1 DIV N 1 MARR 2 DATE Thursday, 26th April 1923 1 RIN 96 0 @F5@ FAM 1 HUSB @I25@ 1 WIFE @I24@ 1 CHIL @I26@ 1 CHIL @I27@ 1 DIV Y 1 MARR 2 DATE Friday, 6th May 1960 2 PLAC Westminster,Cathedral,London,England 1 RIN 97 0 @F6@ FAM 1 HUSB @I10@ 1 WIFE @I9@ 1 CHIL @I11@ 1 CHIL @I15@ 1 CHIL @I19@ 1 CHIL @I23@ 1 DIV N 1 MARR 2 DATE Thursday, 20th November 1947 2 PLAC Westminster,Abbey,London,England 1 RIN 98 0 @F7@ FAM 1 HUSB @I16@ 1 WIFE @I15@ 1 CHIL @I17@ 1 CHIL @I18@ 1 DIV N 1 MARR 2 DATE Wednesday, 14th November 1973 2 PLAC Westminster,Abbey,London,England 1 RIN 99 0 @F8@ FAM 1 HUSB @I11@ 1 WIFE @I12@ 1 CHIL @I13@ 1 CHIL @I14@ 1 DIV N 1 MARR 2 DATE Wednesday, 29th July 1981 2 PLAC St. Paul's,Cathedral,London,England 1 RIN 100 0 @F9@ FAM 1 HUSB @I62@ 1 WIFE @I63@ 1 CHIL @I64@ 1 CHIL @I70@ 1 CHIL @I77@ 1 MARR 2 DATE Thursday, 29th November 1934 2 PLAC Westminster,Abbey,London,England 1 RIN 101 0 @F10@ FAM 1 HUSB @I29@ 1 WIFE @I28@ 1 CHIL @I30@ 1 CHIL @I48@ 1 MARR 2 DATE Tuesday, 28th February 1922 2 PLAC Westminster,Abbey,London,England 1 RIN 102 0 @F11@ FAM 1 HUSB @I54@ 1 WIFE @I55@ 1 CHIL @I56@ 1 CHIL @I57@ 1 MARR 2 DATE Wednesday, 6th November 1935 2 PLAC Buckingham,Palace,London,England 1 RIN 103 0 @F12@ FAM 1 HUSB @I5@ 1 WIFE @I6@ 1 DIV N 1 MARR 2 DATE Thursday, 3rd June 1937 2 PLAC Chateau de Cande,Monts,,France 1 RIN 104 0 @F13@ FAM 1 HUSB @I57@ 1 WIFE @I58@ 1 CHIL @I59@ 1 CHIL @I60@ 1 CHIL @I61@ 1 MARR 2 DATE Wednesday, 19th July 1972 1 RIN 105 0 @F14@ FAM 1 WIFE @I6@ 1 DIV Y 1 MARR 2 DATE 1916 1 RIN 106 0 @F15@ FAM 1 WIFE @I6@ 1 DIV Y 1 MARR 2 DATE 1928 1 RIN 107 0 @F16@ FAM 1 CHIL @I10@ 1 MARR 2 DATE 1903 1 RIN 108 0 @F17@ FAM 1 HUSB @I71@ 1 WIFE @I70@ 1 CHIL @I72@ 1 CHIL @I74@ 1 MARR 2 DATE Friday, 19th April 1963 2 PLAC ,,England 1 RIN 109 0 @F18@ FAM 1 HUSB @I64@ 1 WIFE @I65@ 1 CHIL @I66@ 1 CHIL @I68@ 1 CHIL @I69@ 1 MARR 2 DATE 1961 1 RIN 110 0 @F19@ FAM 1 CHIL @I4@ 1 RIN 111 0 @F20@ FAM 1 CHIL @I8@ 1 RIN 112 0 @F21@ FAM 1 HUSB @I19@ 1 WIFE @I20@ 1 CHIL @I21@ 1 CHIL @I22@ 1 MARR 2 DATE Wednesday, 23rd July 1986 2 PLAC Westminster,Abbey,London,England 1 RIN 113 0 @F22@ FAM 1 CHIL @I20@ 1 DIV Y 1 MARR 2 DATE Thursday, 19th January 1956 2 PLAC St. Margarets,Westminster,England 1 RIN 114 0 @F23@ FAM 1 CHIL @I6@ 1 RIN 115 0 @F24@ FAM 1 CHIL @I2@ 1 MARR 2 DATE 1842 1 RIN 116 0 @F25@ FAM 1 CHIL @I63@ 1 MARR 2 DATE 1902 1 RIN 117 0 @F26@ FAM 1 CHIL @I12@ 1 DIV Y 1 MARR 2 DATE 1954 2 PLAC Westminster,Abbey,London,England 1 RIN 118 0 @F27@ FAM 1 HUSB @I30@ 1 WIFE @I31@ 1 CHIL @I32@ 1 CHIL @I38@ 1 CHIL @I42@ 1 DIV Y 1 MARR 2 DATE 1949 1 RIN 119 0 @F28@ FAM 1 HUSB @I48@ 1 WIFE @I49@ 1 CHIL @I50@ 1 DIV Y 1 MARR 2 DATE 1952 1 RIN 120 0 @F29@ FAM 1 HUSB @I30@ 1 WIFE @I46@ 1 CHIL @I47@ 1 MARR 2 DATE 1967 1 RIN 121 0 @F30@ FAM 1 HUSB @I48@ 1 WIFE @I52@ 1 CHIL @I53@ 1 MARR 2 DATE 1978 1 RIN 122 0 @F31@ FAM 1 HUSB @I77@ 1 WIFE @I78@ 1 CHIL @I79@ 1 CHIL @I80@ 1 MARR 2 DATE Friday, 30th June 1978 2 PLAC Vienna,Austria 1 RIN 123 0 @F32@ FAM 1 WIFE @I78@ 1 DIV Y 1 MARR 2 DATE Sunday, 19th September 1971 1 RIN 124 0 @F33@ FAM 1 CHIL @I55@ 1 RIN 125 0 @F34@ FAM 1 HUSB @I32@ 1 WIFE @I33@ 1 CHIL @I34@ 1 CHIL @I35@ 1 CHIL @I36@ 1 CHIL @I37@ 1 MARR 2 DATE 1979 1 RIN 126 0 @F35@ FAM 1 HUSB @I38@ 1 WIFE @I39@ 1 CHIL @I40@ 1 CHIL @I41@ 1 MARR 2 DATE 1973 1 RIN 127 0 @F36@ FAM 1 HUSB @I42@ 1 WIFE @I43@ 1 CHIL @I44@ 1 CHIL @I45@ 1 MARR 2 DATE 1981 1 RIN 128 0 @F37@ FAM 1 CHIL @I65@ 1 RIN 129 0 @F38@ FAM 1 HUSB @I50@ 1 WIFE @I51@ 1 MARR 2 DATE 1979 1 RIN 130 0 @F39@ FAM 1 HUSB @I75@ 1 WIFE @I74@ 1 CHIL @I76@ 1 MARR 2 DATE Monday, 19th February 1990 1 RIN 131 0 @F40@ FAM 1 CHIL @I16@ 1 RIN 132 0 @F41@ FAM 1 HUSB @I66@ 1 WIFE @I67@ 1 MARR 2 DATE Tuesday, 19th January 1988 1 RIN 133 0 @F42@ FAM 1 WIFE @I67@ 1 DIV Y 1 RIN 134 0 @F43@ FAM 1 CHIL @I67@ 1 DIV Y 1 RIN 135 0 @F44@ FAM 1 HUSB @I25@ 1 MARR 2 DATE Sunday, 17th December 1978 1 RIN 136 0 @F45@ FAM 1 HUSB @I72@ 1 WIFE @I73@ 1 MARR 2 DATE AFT 1989 1 RIN 137 0 @F46@ FAM 1 WIFE @I46@ 1 RIN 138 0 @F47@ FAM 1 CHIL @I31@ 1 RIN 139 1 SOUR @S1@ 2 PAGE 1 0 @S1@ SOUR 1 TEXT Source text 0 @N1@ NOTE Line 1 1 CONT Line 2 0 TRLR Gedcom-1.19/cgi-bin/0000755000175000017500000000000012204002636012603 5ustar pjcjpjcjGedcom-1.19/cgi-bin/gedcom.cgi0000755000175000017500000000131112204002473014523 0ustar pjcjpjcj#!/usr/bin/perl -w # Copyright 2001-2013, Paul Johnson (paul@pjcj.net) # 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.19 - 18th August 2013 use strict; require 5.005; use lib "/var/www/Gedcom/lib"; use CGI qw(:cgi :html); use Gedcom::CGI 1.19; my $op = param("op"); eval { Gedcom::CGI->$op() }; if (my $error = $@) { print header, start_html, h1("Gedcom error"), "Unable to run $op.", pre($error), end_html; } __END__ =head1 NAME main.cgi Version 1.19 - 18th August 2013 =head1 SYNOPSIS =head1 DESCRIPTION =cut Gedcom-1.19/META.yml0000664000175000017500000000123712204002636012551 0ustar pjcjpjcj--- abstract: 'Interface to genealogy GEDCOM files' author: - 'Paul Johnson (paul@pjcj.net)' build_requires: {} dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.120921' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Gedcom no_index: directory: - t - inc recommends: Date::Manip: 0 Parse::RecDescent: 0 Roman: 0 resources: X_mailing_list: http://lists.perl.org/list/perl-gedcom.html bugtracker: https://github.com/pjcj/Gedcom.pm/issues license: http://dev.perl.org/licenses/ repository: http://github.com/pjcj/Gedcom.pm version: 1.19 Gedcom-1.19/Makefile.PL0000644000175000017500000001505212204001536013246 0ustar pjcjpjcj#!/usr/bin/perl -w # Copyright 1998-2013, Paul Johnson (paul@pjcj.net) # 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 use strict; require 5.005; use ExtUtils::MakeMaker; use ExtUtils::Manifest "maniread"; if (0) # For automating webservices testing { eval q{ use Apache::TestMM qw(test clean); Apache::TestMM::filter_args(); Apache::TestMM::generate_script("t/TEST"); }; } $| = 1; my $Version = "1.19"; my $Date = "18th August 2013"; my $Author = 'paul@pjcj.net'; my @perlbug = ("perlbug", "-a", $Author, "-s", "Installation of Gedcom $Version"); my $Perlbug = join " ", map { / / ? "'$_'" : $_ } @perlbug; my @files = sort keys %{maniread()}; my @versions = grep { !/README|travis|Makefile\.PL/ } @files; $ExtUtils::MakeMaker::Verbose = 0; WriteMakefile ( NAME => "Gedcom", VERSION => $Version, AUTHOR => 'Paul Johnson (paul@pjcj.net)', ABSTRACT => "Interface to genealogy GEDCOM files", DIR => [], EXE_FILES => [ "cgi-bin/gedcom.cgi" ], PREREQ_PM => { "Text::Soundex" => 0 }, META_MERGE => { license => [ "perl_5" ], release_status => "stable", prereqs => { runtime => { recommends => { "Date::Manip" => 0, "Parse::RecDescent" => 0, "Roman" => 0, }, }, }, resources => { license => [ "http://dev.perl.org/licenses/" ], bugtracker => { web => "https://github.com/pjcj/Gedcom.pm/issues", }, repository => { type => "git", url => "http://github.com/pjcj/Gedcom.pm", web => "http://github.com/pjcj/Gedcom.pm", }, x_mailing_list => "http://lists.perl.org/list/perl-gedcom.html", }, "meta-spec" => { version => 2, url => "http://search.cpan.org/perldoc?CPAN::Meta::Spec", }, }, dist => { COMPRESS => "gzip --best --force" }, clean => { FILES => join " ", map { "$_.version" } @versions }, depend => { distdir => "@files" }, ); print "\n"; print "checking for Date::Manip.pm........ "; eval "use Date::Manip"; if (my $m = $INC{"Date/Manip.pm"}) { print "$m\n"; } else { print <new("Makefile.PL"); $fh->getline; $fh->input_line_number; EOE if ($@) { print <<'EOM'; broken You have a broken IO::Handle module. In particular, the input_line_number method causes an error. Gedcom.pm will work around the problem, but if you experience other problems with this function, or your use of $., you may wish to solve the problem. Perl 5.005_03 and (I believe) some developer releases have this problem, as does IO.pm version 1.20. The problem is fixed as from 5.005_57. If you would like to patch your Perl, my patch is available at http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1999-04/msg02366.html or send me mail. EOM } else { print "working\n"; } print < README # Webservies section restart : all \t t/TEST -stop && rm -f t/logs/*log && t/TEST -start \$(TEST_OPTIONS) restart_cover : all \t t/TEST -stop && cover && rm -f t/logs/*log && \\ t/TEST -defines COVER -one-process -start \$(TEST_OPTIONS) stop : all \t t/TEST -stop runtestcover : all \t rm -f t/logs/*log && \\ DEVEL_COVER=1 t/TEST -defines COVER -one-process -verbose \$(TEST_OPTIONS) && \\ cover -report html_basic mytestcover : all \t cover -delete && \\ rm -f t/logs/*log && \\ DEVEL_COVER=1 t/TEST -defines COVER -one-process \$(TEST_OPTIONS) && \\ cover -report html_basic # cover : mytestcover cgi : all install \t cp `dirname \$(PERL)`/gedcom.cgi cgi-bin && \\ rm *.ged && \\ ln -s ../ged/* . # Reports ok : \t \@$Perlbug -okay || echo "Please send your report manually to $Author" nok : \t \@$Perlbug -nokay || echo "Please send your report manually to $Author" ] } Gedcom-1.19/gedcom-5.5-strict.grammar0000644000175000017500000003260612204002473015722 0ustar pjcjpjcj GEDCOM: = 0 <
> {1:1} 0 <> {0:1} 0 <> {0:M} 0 TRLR {1:1} HEADER: = n HEAD {1:1} +1 SOUR {1:1} +2 VERS {0:1} +2 NAME {0:1} +2 CORP {0:1} +3 <> {0:1} +2 DATA {0:1} +3 DATE {0:1} +3 COPR {0:1} +1 DEST {0:1*} +1 DATE {0:1} +2 TIME {0:1} +1 SUBM @@ {1:1} +1 SUBN @@ {0:1} +1 FILE {0:1} +1 COPR {0:1} +1 GEDC {1:1} +2 VERS {1:1} +2 FORM {1:1} +1 CHAR {1:1} +2 VERS {0:1} +1 LANG {0:1} +1 PLAC {0:1} +2 FORM {1:1} +1 NOTE {0:1} +2 CONT {0:M} +2 CONC {0:M} RECORD: = [ n <> {1:1} | n <> {1:1} | n <> {1:M} | n <> {1:1} | n <> {1:1} | n <> {1:1} | n <> {1:1} ] FAM_RECORD: = n @@ FAM {1:1} +1 <> {0:M} +2 HUSB {0:1} +3 AGE {1:1} +2 WIFE {0:1} +3 AGE {1:1} +1 HUSB @@ {0:1} +1 WIFE @@ {0:1} +1 CHIL @@ {0:M} +1 NCHI {0:1} +1 SUBM @@ {0:M} +1 <> {0:M} +1 <> {0:M} +1 <> {0:M} +1 <> {0:M} +1 REFN {0:M} +2 TYPE {0:1} +1 RIN {0:1} +1 <> {0:1} INDIVIDUAL_RECORD: = n @@ INDI {1:1} +1 RESN {0:1} +1 <> {0:M} +1 SEX {0:1} +1 <> {0:M} +1 <> {0:M} +1 <> {0:M} +1 <> {0:M} +1 <> {0:M} +1 SUBM @@ {0:M} +1 <> {0:M} +1 ALIA @@ {0:M} +1 ANCI @@ {0:M} +1 DESI @@ {0:M} +1 <> {0:M} +1 <> {0:M} +1 <> {0:M} +1 RFN {0:1} +1 AFN {0:1} +1 REFN {0:M} +2 TYPE {0:1} +1 RIN {0:1} +1 <> {0:1} MULTIMEDIA_RECORD: = n @@ OBJE {1:1} +1 FORM {1:1} +1 TITL {0:1} +1 <> {0:M} +1 BLOB {1:1} +2 CONT {1:M} +1 OBJE @@ {0:1} +1 REFN {0:M} +2 TYPE {0:1} +1 RIN {0:1} +1 <> {0:1} NOTE_RECORD: = n @@ NOTE {1:1} +1 CONC {0:M} +1 CONT {0:M} +1 <> {0:M} +1 REFN {0:M} +2 TYPE {0:1} +1 RIN {0:1} +1 <> {0:1} REPOSITORY_RECORD: = n @@ REPO {1:1} +1 NAME {0:1} +1 <> {0:1} +1 <> {0:M} +1 REFN {0:M} +2 TYPE {0:1} +1 RIN {0:1} +1 <> {0:1} SOURCE_RECORD: = n @@ SOUR {1:1} +1 DATA {0:1} +2 EVEN {0:M} +3 DATE {0:1} +3 PLAC {0:1} +2 AGNC {0:1} +2 <> {0:M} +1 AUTH {0:1} +2 CONT {0:M} +2 CONC {0:M} +1 TITL {0:1} +2 CONT {0:M} +2 CONC {0:M} +1 ABBR {0:1} +1 PUBL {0:1} +2 CONT {0:M} +2 CONC {0:M} +1 TEXT {0:1} +2 CONT {0:M} +2 CONC {0:M} +1 <> {0:1} +1 <> {0:M} +1 <> {0:M} +1 REFN {0:M} +2 TYPE {0:1} +1 RIN {0:1} +1 <> {0:1} SUBMISSION_RECORD: = n @@ SUBN {1:1] +1 SUBM @@ {0:1} +1 FAMF {0:1} +1 TEMP {0:1} +1 ANCE {0:1} +1 DESC {0:1} +1 ORDI {0:1} +1 RIN {0:1} SUBMITTER_RECORD: = n @@ SUBM {1:1} +1 NAME {1:1} +1 <> {0:1} +1 <> {0:M} +1 LANG {0:3} +1 RFN {0:1} +1 RIN {0:1} +1 <> {0:1} ADDRESS_STRUCTURE: = n ADDR {0:1} +1 CONT {0:M} +1 ADR1 {0:1} +1 ADR2 {0:1} +1 CITY {0:1} +1 STAE {0:1} +1 POST {0:1} +1 CTRY {0:1} n PHON {0:3} ASSOCIATION_STRUCTURE: = n ASSO @@ {0:M} +1 TYPE {1:1} +1 RELA {1:1} +1 <> {0:M} +1 <> {0:M} CHANGE_DATE: = n CHAN {1:1} +1 DATE {1:1} +2 TIME {0:1} +1 <> {0:M} CHILD_TO_FAMILY_LINK: = n FAMC @@ {1:1} +1 PEDI {0:M} +1 <> {0:M} EVENT_DETAIL: = n TYPE {0:1} n DATE {0:1} n <> {0:1} n <> {0:1} n AGE {0:1} n AGNC {0:1} n CAUS {0:1} n <> {0:M} n <> {0:M} n <> {0:M} FAMILY_EVENT_STRUCTURE: = [ n ANUL {1:1} +1 <> {0:1} | n CENS {1:1} +1 <> {0:1} | n DIV {1:1} +1 <> {0:1} | n DIVF {1:1} +1 <> {0:1} | n ENGA {1:1} +1 <> {0:1} | n MARR {1:1} +1 <> {0:1} | n MARB {1:1} +1 <> {0:1} | n MARC {1:1} +1 <> {0:1} | n MARL {1:1} +1 <> {0:1} | n MARS {1:1} +1 <> {0:1} | n EVEN {1:1} +1 <> {0:1} ] INDIVIDUAL_ATTRIBUTE_STRUCTURE: = [ n CAST {1:1} +1 <> {0:1} | n DSCR {1:1} +1 <> {0:1} | n EDUC {1:1} +1 <> {0:1} | n IDNO {1:1}* +1 <> {0:1} | n NATI {1:1} +1 <> {0:1} | n NCHI {1:1} +1 <> {0:1} | n NMR {1:1} +1 <> {0:1} | n OCCU {1:1} +1 <> {0:1} | n PROP {1:1} +1 <> {0:1} | n RELI {1:1} +1 <> {0:1} | n RESI {1:1} +1 <> {0:1} | n SSN {0:1} +1 <> {0:1} | n TITL {1:1} +1 <> {0:1} ] INDIVIDUAL_EVENT_STRUCTURE: = [ n BIRT {1:1} +1 <> {0:1} +1 FAMC @@ {0:1} | n CHR {1:1} +1 <> {0:1} +1 FAMC @@ {0:1} | n DEAT {1:1} +1 <> {0:1} | n BURI {1:1} +1 <> {0:1} | n CREM {1:1} +1 <> {0:1} | n ADOP {1:1} +1 <> {0:1} +1 FAMC @@ {0:1} +2 ADOP {0:1} | n BAPM {1:1} +1 <> {0:1} | n BARM {1:1} +1 <> {0:1} | n BASM {1:1} +1 <> {0:1} | n BLES {1:1} +1 <> {0:1} | n CHRA {1:1} +1 <> {0:1} | n CONF {1:1} +1 <> {0:1} | n FCOM {1:1} +1 <> {0:1} | n ORDN {1:1} +1 <> {0:1} | n NATU {1:1} +1 <> {0:1} | n EMIG {1:1} +1 <> {0:1} | n IMMI {1:1} +1 <> {0:1} | n CENS {1:1} +1 <> {0:1} | n PROB {1:1} +1 <> {0:1} | n WILL {1:1} +1 <> {0:1} | n GRAD {1:1} +1 <> {0:1} | n RETI {1:1} +1 <> {0:1} | n EVEN {1:1} +1 <> {0:1} ] LDS_INDIVIDUAL_ORDINANCE: = [ n BAPL {1:1} +1 STAT {0:1} +1 DATE {0:1} +1 TEMP {0:1} +1 PLAC {0:1} +1 <> {0:M} +1 <> {0:M} | n CONL {1:1} +1 STAT {0:1} +1 DATE {0:1} +1 TEMP {0:1} +1 PLAC {0:1} +1 <> {0:M} +1 <> {0:M} | n ENDL {1:1} +1 STAT {0:1} +1 DATE {0:1} +1 TEMP {0:1} +1 PLAC {0:1} +1 <> {0:M} +1 <> {0:M} | n SLGC {1:1} +1 STAT {0:1} +1 DATE {0:1} +1 TEMP {0:1} +1 PLAC {0:1} +1 FAMC @@ {1:1} +1 <> {0:M} +1 <> {0:M} ] LDS_SPOUSE_SEALING: = n SLGS {1:1} +1 STAT {0:1} +1 DATE {0:1} +1 TEMP {0:1} +1 PLAC {0:1} +1 <> {0:M} +1 <> {0:M} MULTIMEDIA_LINK: = [ n OBJE @@ {1:1} | n OBJE {1:1} +1 FORM {1:1} +1 TITL {0:1} +1 FILE {1:1} +1 <> {0:M} ] NOTE_STRUCTURE: = [ n NOTE @@ {1:1} +1 <> {0:M} | n NOTE {1:1} +1 CONC {0:M} +1 CONT {0:M} +1 <> {0:M} ] PERSONAL_NAME_STRUCTURE: = n NAME {1:1} +1 NPFX {0:1} +1 GIVN {0:1} +1 NICK {0:1} +1 SPFX {0:1} +1 SURN {0:1} +1 NSFX {0:1} +1 <> {0:M} +1 <> {0:M} PLACE_STRUCTURE: = n PLAC {1:1} +1 FORM {0:1} +1 <> {0:M} +1 <> {0:M} SOURCE_CITATION: = [ n SOUR @@ {1:1} +1 PAGE {0:1} +1 EVEN {0:1} +2 ROLE {0:1} +1 DATA {0:1} +2 DATE {0:1} +2 TEXT {0:M} +3 CONC {0:M} +3 CONT {0:M} +1 QUAY {0:1} +1 <> {0:M} +1 <> {0:M} | n SOUR {1:1} +1 CONC {0:M} +1 CONT {0:M} +1 TEXT {0:M} +2 CONC {0:M} +2 CONT {0:M} +1 <> {0:M} ] SOURCE_REPOSITORY_CITATION: = n REPO @@ {1:1} +1 <> {0:M} +1 CALN {0:M} +2 MEDI {0:1} SPOUSE_TO_FAMILY_LINK: = n FAMS @@ {1:1} +1 <> {0:M} Gedcom-1.19/utils/0000755000175000017500000000000012204002636012433 5ustar pjcjpjcjGedcom-1.19/utils/makeh0000644000175000017500000000205412204002474013444 0ustar pjcjpjcj#!/usr/bin/perl # Copyright 2001-2013, Paul Johnson (paul@pjcj.net) # 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 use strict; use warnings; my $Command = { set_version => sub { my ($command, $version, $date, @files) = @_; local ($^I, @ARGV) = (".bak", @files); while (<>) { s/(^\s*\$VERSION = ")\d+\.\d+(";)/$1$version$2/; s/(Version )\d+\.\d+( - ).*/$1$version$2$date/; s/(^\s*use Gedcom(?:::\w+)*\s+)\d+\.\d+;/$1$version;/; print; } }, make_readme => sub { my ($command) = @_; local @ARGV; while (<>) { print if (/NAME/ ... /^[A-Z ]+$/) =~ /^\d+$/; print if (/DESCRIPTION/ ... /^[A-Z ]+$/) =~ /^\d+$/; } }, }; sub main { my ($command) = @ARGV; die "No such command: $command" unless $Command->{$command}; $Command->{$command}->(@ARGV) } main Gedcom-1.19/utils/session.vim0000644000175000017500000000061212204002474014632 0ustar pjcjpjcj1,999bd e Makefile.PL e MANIFEST e CHANGES e TODO e BUGS e lib/Gedcom.pm e lib/Gedcom/Item.pm e lib/Gedcom/Grammar.pm e lib/Gedcom/Record.pm e lib/Gedcom/Individual.pm e lib/Gedcom/Family.pm e lib/Gedcom/Event.pm e lib/Gedcom/Comparison.pm e lib/Gedcom/CGI.pm e lib/Gedcom/WebServices.pm e lib/Gedcom/LifeLines.pm e parse_grammar e lines2perl e gedcom-5.5.grammar e t/Basic.pm e ged e #1 Tlist Gedcom-1.19/utils/all_versions0000755000175000017500000000272012204002474015062 0ustar pjcjpjcj#!/usr/bin/perl # Copyright 2004-2013, Paul Johnson (paul@pjcj.net) # 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 use strict; use warnings; use Getopt::Long; my $Options = { dry_run => 0, ignore_failure => 0, version => [], }; sub get_options { die "Bad option" unless GetOptions($Options, # Store the options in the Options hash. qw( dry_run! ignore_failure! version=s )); $Options->{version} = [ "5.6.1", map { ($_, "$_-thr") } qw( 5.6.2 5.8.0 5.8.1 5.8.2 5.8.3 5.8.4 5.8.5 5.8.6 5.8.7 5.8.8 5.8.9 5.10.0 5.10.1 5.11.0 5.12.0-RC5 ) ] unless @{$Options->{version}}; $Options->{version} = [ grep eval { !system "perl$_ -v" }, @{$Options->{version}} ]; } sub sys { my ($command) = @_; print "$command\n"; return if $Options->{dry_run}; my $ret = system $command; die "command failed: $?" if $ret && !$Options->{ignore_failure}; } get_options; my $command = "@ARGV" or die "Usage: $0 [-v version] command\n"; for my $v (@{$Options->{version}}) { my $perl = "perl$v"; sys "rm -rf cover_db"; sys "$perl Makefile.PL"; sys "make clean"; sys "$perl Makefile.PL"; sys "make"; sys $command; } Gedcom-1.19/lib/0000755000175000017500000000000012204002636012041 5ustar pjcjpjcjGedcom-1.19/lib/Gedcom.pm0000644000175000017500000010453712204002473013606 0ustar pjcjpjcj# Copyright 1998-2013, Paul Johnson (paul@pjcj.net) # 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; use Carp; use Data::Dumper; use FileHandle; BEGIN { eval "use Text::Soundex" } # We'll use this if it is available use vars qw($VERSION $AUTOLOAD %Funcs); my $Tags; my %Top_tag_order; BEGIN { $VERSION = "1.19"; $Tags = { ABBR => "Abbreviation", ADDR => "Address", ADOP => "Adoption", ADR1 => "Address1", ADR2 => "Address2", AFN => "Afn", AGE => "Age", AGNC => "Agency", ALIA => "Alias", ANCE => "Ancestors", ANCI => "Ances Interest", ANUL => "Annulment", ASSO => "Associates", AUTH => "Author", BAPL => "Baptism-LDS", BAPM => "Baptism", BARM => "Bar Mitzvah", BASM => "Bas Mitzvah", BIRT => "Birth", BLES => "Blessing", BLOB => "Binary Object", BURI => "Burial", CALN => "Call Number", CAST => "Caste", CAUS => "Cause", CENS => "Census", CHAN => "Change", CHAR => "Character", CHIL => "Child", CHR => "Christening", CHRA => "Adult Christening", CITY => "City", CONC => "Concatenation", CONF => "Confirmation", CONL => "Confirmation L", CONT => "Continued", COPR => "Copyright", CORP => "Corporate", CREM => "Cremation", CTRY => "Country", DATA => "Data", DATE => "Date", DEAT => "Death", DESC => "Descendants", DESI => "Descendant Int", DEST => "Destination", DIV => "Divorce", DIVF => "Divorce Filed", DSCR => "Phy Description", EDUC => "Education", EMIG => "Emigration", ENDL => "Endowment", ENGA => "Engagement", EVEN => "Event", FAM => "Family", FAMC => "Family Child", FAMF => "Family File", FAMS => "Family Spouse", FCOM => "First Communion", FILE => "File", FORM => "Format", GEDC => "Gedcom", GIVN => "Given Name", GRAD => "Graduation", HEAD => "Header", HUSB => "Husband", IDNO => "Ident Number", IMMI => "Immigration", INDI => "Individual", LANG => "Language", LEGA => "Legatee", MARB => "Marriage Bann", MARC => "Marr Contract", MARL => "Marr License", MARR => "Marriage", MARS => "Marr Settlement", MEDI => "Media", NAME => "Name", NATI => "Nationality", NATU => "Naturalization", NCHI => "Children_count", NICK => "Nickname", NMR => "Marriage_count", NOTE => "Note", NPFX => "Name_prefix", NSFX => "Name_suffix", OBJE => "Object", OCCU => "Occupation", ORDI => "Ordinance", ORDN => "Ordination", PAGE => "Page", PEDI => "Pedigree", PHON => "Phone", PLAC => "Place", POST => "Postal_code", PROB => "Probate", PROP => "Property", PUBL => "Publication", QUAY => "Quality Of Data", REFN => "Reference", RELA => "Relationship", RELI => "Religion", REPO => "Repository", RESI => "Residence", RESN => "Restriction", RETI => "Retirement", RFN => "Rec File Number", RIN => "Rec Id Number", ROLE => "Role", SEX => "Sex", SLGC => "Sealing Child", SLGS => "Sealing Spouse", SOUR => "Source", SPFX => "Surn Prefix", SSN => "Soc Sec Number", STAE => "State", STAT => "Status", SUBM => "Submitter", SUBN => "Submission", SURN => "Surname", TEMP => "Temple", TEXT => "Text", TIME => "Time", TITL => "Title", TRLR => "Trailer", TYPE => "Type", VERS => "Version", 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)) { $Funcs{$tag} = $Funcs{lc $tag} = $tag; if ($name) { $name =~ s/ /_/g; $Funcs{lc $name} = $tag; } } } sub DESTROY {} sub AUTOLOAD { my ($self) = @_; # don't change @_ because of the goto my $func = $AUTOLOAD; # print "autoloading $func\n"; $func =~ s/^.*:://; my $tag; croak "Undefined subroutine $func called" if $func !~ /^(add|get)_(.*)$/ || !($tag = $Funcs{lc $2}) || !exists $Top_tag_order{$tag}; no strict "refs"; if ($1 eq "add") { *$func = sub { my $self = shift; my ($arg, $val) = @_; my $xref; if (ref $arg) { $xref = $arg->{xref}; } else { $val = $arg; } my $record = $self->add_record(tag => $tag, val => $val); if (defined $val && $tag eq "NOTE") { $record->{value} = $val; } $xref = $tag eq "SUBM" ? "SUBM" : substr $tag, 0, 1 unless defined $xref; unless ($tag =~ /^(HEAD|TRLR)$/) { croak "Invalid xref $xref requested in $func" unless $xref =~ /^[^\W\d_]+(\d*)$/; $xref = $self->next_xref($xref) unless length $1; $record->{xref} = $xref; $self->{xrefs}{$xref} = $record; } $record }; } 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.19; use Gedcom::Individual 1.19; use Gedcom::Family 1.19; use Gedcom::Event 1.19; sub new { my $proto = shift; my $class = ref($proto) || $proto; @_ = (gedcom_file => @_) if @_ == 1; my $self = { records => [], tags => $Tags, read_only => 0, types => {}, xrefs => {}, encoding => "ansel", @_ }; # TODO - find a way to do this nicely for different grammars $self->{types}{INDI} = "Individual"; $self->{types}{FAM} = "Family"; $self->{types}{$_} = "Event" for qw( ADOP ANUL BAPM BARM BASM BIRT BLES BURI CAST CENS CENS CHR CHRA CONF CREM DEAT DIV DIVF DSCR EDUC EMIG ENGA EVEN EVEN FCOM GRAD IDNO IMMI MARB MARC MARL MARR MARS NATI NATU NCHI NMR OCCU ORDN PROB PROP RELI RESI RETI SSN WILL ); bless $self, $class; # first read in the grammar 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 { $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"}; } my @c = ($self->{grammar} = $grammar); while (@c) { @c = map { $_->{top} = $grammar; @{$_->{items}} } @c; } # 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}) { # 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-2013, Paul Johnson (paul@pjcj.net)'); $l1 = $l0->add("NOTE", ""); for (split /\n/, <<'EOH') This output was generated by Gedcom.pm. Gedcom.pm is Copyright 1999-2013, Paul Johnson (paul@pjcj.net) Version 1.19 - 18th August 2013 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", uc ($self->{encoding} || "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->collect_xrefs; $self } sub set_encoding { my $self = shift; ($self->{encoding}) = @_; } sub write { my $self = shift; my $file = shift or die "No filename specified"; my $flush = shift; $self->{fh} = FileHandle->new($file, "w") or die "Can't open $file: $!"; binmode $self->{fh}, ":encoding(UTF-8)" if $self->{encoding} eq "utf-8" && $] >= 5.8; $self->{record}->write($self->{fh}, -1, $flush); $self->{fh}->close or die "Can't close $file: $!"; } sub write_xml { my $self = shift; my $file = shift or die "No filename specified"; $self->{fh} = FileHandle->new($file, "w") or die "Can't open $file: $!"; binmode $self->{fh}, ":encoding(UTF-8)" if $self->{encoding} eq "utf-8" && $] >= 5.8; $self->{fh}->print(<<'EOH'); \n\n"); $self->{record}->write_xml($self->{fh}); $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->{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; my ($callback) = @_; $self->{validate_callback} = $callback; my $ok = $self->{record}->validate_syntax; for my $item (@{$self->{record}->_items}) { $ok = 0 unless $item->validate_semantics; } $ok } sub normalise_dates { my $self = shift; $self->{record}->normalise_dates(@_); } sub renumber { my $self = shift; my (%args) = @_; $self->resolve_xrefs; # initially, renumber any records passed in for my $xref (@{$args{xrefs}}) { $self->{xrefs}{$xref}->renumber(\%args, 1) if exists $self->{xrefs}{$xref}; } # now, renumber any records left over $_->renumber(\%args, 1) for @{$self->{record}->_items}; # actually change the xref for my $record (@{$self->{record}->_items}) { $record->{xref} = delete $record->{new_xref}; delete $record->{recursed} } # and update the xrefs $self->collect_xrefs; %args } sub sort_sub { # subroutine to sort on tag order first, and then on xref my $t = sub { my ($r) = @_; return -2 unless defined $r->{tag}; exists $Top_tag_order{$r->{tag}} ? $Top_tag_order{$r->{tag}} : -1 }; my $x = sub { my ($r) = @_; return -2 unless defined $r->{xref}; $r->{xref} =~ /(\d+)/; defined $1 ? $1 : -1 }; sub { $t->($a) <=> $t->($b) || $x->($a) <=> $x->($b) } } sub order { my $self = shift; my $sort_sub = shift || sort_sub; # use default sort unless one is passed in @{$self->{record}{items}} = sort $sort_sub @{$self->{record}->_items} } sub items { my $self = shift; @{$self->{record}->_items} } sub heads { grep $_->tag eq "HEAD", shift->items } sub submitters { grep $_->tag eq "SUBM", shift->items } sub individuals { grep ref eq "Gedcom::Individual", shift->items } sub families { grep ref eq "Gedcom::Family", shift->items } sub notes { grep $_->tag eq "NOTE", shift->items } sub repositories { grep $_->tag eq "REPO", shift->items } sub sources { grep $_->tag eq "SOUR", shift->items } sub trailers { grep $_->tag eq "TRLR", shift->items } sub get_individual { my $self = shift; my $name = "@_"; my $all = wantarray; my @i; my $i = $self->resolve_xref($name) || $self->resolve_xref(uc $name); if ($i) { return $i unless $all; push @i, $i; } # search for the name in the specified order my $ordered = sub { my ($n, @ind) = @_; map { $_->[1] } grep { $_ && $_->[0] =~ $n } @ind }; # search for the name in any order my $unordered = sub { my ($names, $t, @ind) = @_; map { $_->[1] } grep { my $i = $_->[0]; my $r = 1; for my $n (@$names) { # remove matches as they are found # we don't want to match the same name twice last unless $r = $i =~ s/$n->[$t]//; } $r } @ind; }; # look for various matches in decreasing order of exactitude my @individuals = $self->individuals; # 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. my @ind = map { [ do { my $n = $_->tag_value("NAME"); defined $n ? $n : "" } => $_ ] } @individuals; for my $n ( map { qr/^$_$/, qr/\b$_\b/, $_ } map { $_, qr/$_/i } qr/\Q$name/ ) { push @i, $ordered->($n, @ind); return $i[0] if !$all && @i; } # create an array with one element per name # each element is an array of REs in decreasing order of exactitude my @names = map { [ map { qr/\b$_\b/, $_ } map { qr/$_/, qr/$_/i } "\Q$_" ] } split / /, $name; for my $t (0 .. $#{$names[0]}) { push @i, $unordered->(\@names, $t, @ind); return $i[0] if !$all && @i; } # check soundex 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; my @s; my %s; for (@i) { unless (exists $s{$_->{xref}}) { push @s, $_; $s{$_->{xref}}++; } } @s } sub next_xref { my $self = shift; my ($type) = @_; my $re = qr/^$type(\d+)$/; my $last = 0; for my $c (@{$self->{record}->_items}) { $last = $1 if defined $c->{xref} and $c->{xref} =~ /$re/ and $1 > $last; } $type . ++$last } sub top_tag { my $self = shift; my ($tag) = @_; $Top_tag_order{$tag} } 1; __END__ =head1 NAME Gedcom - a module to manipulate Gedcom genealogy files Version 1.19 - 18th August 2013 =head1 SYNOPSIS use Gedcom; my $ged = Gedcom->new; my $ged = Gedcom->new($gedcom_file); my $ged = Gedcom->new(grammar_version => "5.5.1", gedcom_file => $gedcom_file, read_only => 1, 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; my %xrefs = $ged->renumber; $ged->order; $ged->set_encoding("utf-8"); $ged->write($new_gedcom_file, $flush); $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; add_submitter add_individual add_family add_note add_repository add_source add_trailer my $source = $ged->get_source("S1"); =head1 DESCRIPTION Copyright 1998-2013, Paul Johnson (paul@pjcj.net) 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 This module provides for manipulation of Gedcom files. Gedcom is a format for storing genealogical information designed by The Church of Jesus Christ of Latter-Day Saints (http://www.lds.org). Information about Gedcom is available as a zip file at ftp://gedcom.org/pub/genealogy/gedcom/gedcom55.zip. Unfortunately, this is only usable if you can access a PC running Windows of some 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 Roman.pm to use the LifeLines function roman from lines2perl The Gedcom format is specified in a grammar file (gedcom-5.5.grammar). Gedcom.pm parses the grammar which is then used to validate and allow manipulation of the Gedcom file. I have only used Gedcom.pm with version 5.5 of the Gedcom grammar, which I had to modify slightly to correct a few errors. The advantage of this approach is that Gedcom.pm should be useful if the Gedcom grammar is ever updated. It also made the software easier to write, and probably more dependable too. I 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 documentation than the previous ones - but if you would like information feel free to send me mail or better still, ask on the mailing list. This module provides some functions which work over the entire Gedcom 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. 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. 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 unless you do some manual housekeeping. 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 would like to have some sort of an idea of the use this software is getting. Apart from being of interest to me, this will guide my 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 and if you use or are interested in this module I would encourage you to join the list. To subscribe send an empty message to S. 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 manipulate it. I find this to be a nice solution. =head1 GETTING STARTED This space is reserved for something of a tutorial. If you learn best by looking at examples, take a look at the test directory, I. The most simple test is I. The first thing to do is to read in the Gedcom file. At its most simple, this will involve a statement such as my $ged = Gedcom->new($gedcom_file); It is now possible to access the records within the gedcom file. Each individual and family is a record. Records can contain other records. For example, an individual is a record. The birth information is a sub-record of the individual, and the date of birth is a sub-record of the birth record. Some records, such as the birth record, are simply containers for other records. Some records have a value, such as the date record, whose value is a date. This is all defined in the Gedcom standard. To access an individual use a statement such as my $i = $ged->get_individual("Paul Johnson"); To access information about the individual, use a function of the same name as the Gedcom tag, or its description. Tags and descriptions are listed at the head of Gedcom.pm. For example for my $b ($i->birth) { } will loop through all the birth records in the individual. Usually there will only be one such record, but there may be zero, one or more. Calling the function in scalar context will return only the first record. my $b = $i->birth; But the second record may be returned with my $b = $i->birth(2); If the record required has a value, for example my $n = $i->name; then the value is returned, in this case the name of the individual. If there is no value, as is the case for the birth record, then the record itself is returned. If there is a value, but the record itself is required, then the get_record() function can be used. Information must be accessed through the Gedcom structure so, for example, the birthdate is accessed via the date record from the birth 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, $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. This is a preferable solution where it is necessary to work down the Gedcom structure. For example my $bd = $i->get_value("birth date"); my $bd = $i->get_value(qw(birth date)); will both return an individual's birth date or undef if there is none. And my @bd = $i->get_value("birth date"); will return all the birth dates. The second birth date, if there is one, is my $bd2 = $i->get_value(["birth", 2], "date"); Using the get_record() function in place of the get_value() function, in all cases will return the record rather than the value. All records are of a type derived from Gedcom::Item. Individuals are of type Gedcom::Individual. Families are of type Gedcom::Family. Events are of type Gedcom::Event. Other records are of type Gedcom::Record which is the base type of Gedcom::Individual, Gedcom::Family and Gedcom::Event. As individuals are of type Gedcom::Individual, the functions in Gedcom::Individual.pm are available. These allow access to relations and other information specific to individuals, for example my @sons = $i->sons; It is possible to get all the individuals in the gedcom file as my @individuals = $ged->individuals; So putting everything together, here is a little program which will print out the names and birthdates of everyone in a GEDCOM file specified on the command line. #!/bin/perl -w use strict; use Gedcom; my $ged = Gedcom->new(shift); for my $i ($ged->individuals) { for my $bd ($i->get_value("birth date")) { print $i->name, " was born on $bd\n"; } } =head1 HASH MEMBERS I have not gone the whole hog with data encapsulation and such within this module. Maybe I should have done. Maybe I will. For now though, the data is accessible though hash members. This is partly because having functions to do this is a little slow, especially on my old DECstation, and partly because of laziness again. I'm not too sure whether this is good or bad laziness yet. Time will tell no doubt. As of version 1.05, you should be able to access all the data through functions, and as of version 1.10 write access is available. I have a faster machine now. Some of the more important hash members are: =head2 $ged->{grammar} This contains the gedcom grammar. See Gedcom::Grammar.pm for more details. =head2 $ged->{record} This contains the top level gedcom record. A record contains a number of items. Each of those items are themselves records. This is the way in which the hierarchies are modelled. If you want to get at the data in the gedcom object, this is where you start. See Gedcom::Record.pm for more details. =head1 METHODS =head2 new my $ged = Gedcom->new; my $ged = Gedcom->new($gedcom_file); my $ged = Gedcom->new(grammar_version => "5.5.1", gedcom_file => $gedcom_file, read_only => 1, callback => $cb); my $ged = Gedcom->new(grammar_file => "gedcom-5.5.grammar", gedcom_file => $gedcom_file); Create a new gedcom object. 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. There are two versions available, 5.5 and 5.5.1. 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 full available version, currently 5.5. 5.5.1 is only a draft, but it is available if you specify it. The read_only parameter indicates that the Gedcom data structure will be used primarily for read_only operations. In this mode the gedcom file is read lazily, such that whenever possible the Gedcom records are not read until they are needed. This can save on both memory and CPU usage, provided that not too much of the gedcom file is needed. If the whole of the gedcom file needs to be read, for example to validate it, or to write it out in a different format, then this option should not be used. When using the read_only option an index file is kept which can also speed up operations. It's usage should be transparent, but will require write access to the directory containing the gedcom file. If you access individuals only by their xref (eg I20) then the index file will allow only the relevant parts of the gedcom file to be read. With or without the read_only option, the gedcom file is accessed in the same fashion and the data structures can be changed. In this respect, the name read_only is not very accurate, but since changing the Gedcom 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. 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 applicable) is being read. Its 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 set_encoding $ged->set_encoding("utf-8"); Valid arguments are "ansel" and "utf-8". Defaults to "ansel" but is set to "utf-8" if the gedcom data was read from a file which was deemed to contain UTF-8, either due to the presence of a BOM or as specified by a CHAR item. Set the encoding for the gedcom file. Calling this directly doesn't alter the CHAR item, but does affect the way in which files are written. =head2 write $ged->write($new_gedcom_file, $flush); Write out the gedcom file. Takes the name of the new gedcom file, and whether or not to indent the output according to the level of the record. $flush defaults to false, but the new file name must be specified. =head2 write_xml $ged->write_xml($new_xml_file); Write the gedcom file as XML. Takes the name of the new gedcom file. Note that this function is experimental. The XML output doesn't conform to any standard that I know of, because I don't know of any standard. If and when such a standard surfaces, and probably even if it doesn't, I'll change the output from this function. If you make use of this function, beware. I'd also be very interested in hearing from you to determine the requirements for the XML. =head2 collect_xrefs $ged->collect_xrefs($callback); Collect all the xrefs into a data structure ($ged->{xrefs}) for easy 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); 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); Validate the gedcom object. This performs a number of consistency checks, but could do even more. $callback is not properly used yet. Any errors found are given out as warnings. If this is unwanted, use $SIG{__WARN__} to catch the warnings. Returns true iff the gedcom object is valid. =head2 normalise_dates $ged->normalise_dates; $ged->normalise_dates("%A, %E %B %Y"); 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 currently "%A, %E %B %Y", but I may change this, as it seems that some programs don't like that format. =head2 renumber $ged->renumber; my %xrefs = $ged->renumber(INDI => 34, FAM => 12, xrefs => [$xref1, $xref2]); 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, 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 $ged->order($ged->sort_sub); Default ordering subroutine. The sort is by record type in the following order: HEAD, SUBM, INDI, FAM, NOTE, TRLR, and then by xref within the type. =head2 order $ged->order; $ged->order($order_sub); Order all the records. Optionally provide a sort subroutine. This orders the entries within the gedcom object, which will affect the order in which they are written out. The default sort function is Gedcom::sort_sub. You will need to ensure that the HEAD record is first and that the TRLR record is last. =head2 individuals my @individuals = $ged->individuals; Return a list of all the individuals. =head2 families my @families = $ged->families; Return a list of all the families. =head2 get_individual my $me = $ged->get_individual("Paul Johnson"); Return a list of all individuals matching the specified name. 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: 1 - Xref 2 - Exact 3 - On word boundaries 4 - Anywhere 5 - Exact, case insensitive 6 - On word boundaries, case insensitive 7 - Anywhere, case insensitive 8 - Names in any order, on word boundaries 9 - Names in any order, anywhere 10 - Names in any order, on word boundaries, case insensitive 11 - Names in any order, anywhere, case insensitive 12 - Soundex code 13 - Soundex of name =head2 next_xref my $xref = $ged->next_xref("I"); 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. Normally you will not want to pass any arguments to the function. Those functions which have an xref (ie not header or trailer) accept an optional first argument { xref => $x } which will use $x as the xref rather than letting the module automatically choose the xref. add_note also accepts an optional second argument which is the text to be used on the first line of the note. =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 Gedcom-1.19/lib/Gedcom/0000755000175000017500000000000012204002636013237 5ustar pjcjpjcjGedcom-1.19/lib/Gedcom/Grammar_5_5_1.pm0000644000175000017500000022220712204002474016060 0ustar pjcjpjcj# Copyright 1998-2013, Paul Johnson (paul@pjcj.net) # 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 # This file was automatically generated from gedcom-5.5.1.grammar # by Paul Johnson,,, # on Sun Aug 18 01:20:28 2013 # Do not edit this file. # Edit gedcom-5.5.1.grammar if changes need to be made. # Edit parse_grammar or Makefile.PL to increase the legibility of this file. # (Removal of the leading spaces nearly halves the size of the file.) # Version 1.19 - 18th August 2013 use strict; require 5.005; package Gedcom::Grammar_5_5_1; use vars qw($VERSION $grammar); $VERSION = 1.19; $grammar = bless( { fh => \*Symbol::GEN2, file => 'gedcom-5.5.1.grammar', gedcom => {}, items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => 0, line => 34, max => 1, min => 1, pointer => '', value => '<
>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => 0, line => 35, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => 0, line => 36, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 37, max => 1, min => 1, tag => 'TRLR' }, 'Gedcom::Grammar' ) ], level => -1, line => 32, structure => 'GEDCOM' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 43, max => 1, min => 0, pointer => '', tag => 'VERS', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 44, max => 1, min => 0, pointer => '', tag => 'NAME', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+3', line => 46, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => '+2', line => 45, max => 1, min => 0, pointer => '', tag => 'CORP', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+3', line => 48, max => 1, min => 0, pointer => '', tag => 'DATE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+4', line => 50, max => 'M', min => 0, pointer => '', tag => 'CONT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+4', line => 51, max => 'M', min => 0, pointer => '', tag => 'CONC', value => '' }, 'Gedcom::Grammar' ) ], level => '+3', line => 49, max => 1, min => 0, pointer => '', tag => 'COPR', value => '' }, 'Gedcom::Grammar' ) ], level => '+2', line => 47, max => 1, min => 0, pointer => '', tag => 'DATA', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 42, max => 1, min => 1, pointer => '', tag => 'SOUR', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 52, max => 1, min => 0, pointer => '', tag => 'DEST', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 54, max => 1, min => 0, pointer => '', tag => 'TIME', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 53, max => 1, min => 0, pointer => '', tag => 'DATE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 55, max => 1, min => 1, pointer => 1, tag => 'SUBM', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 56, max => 1, min => 0, pointer => 1, tag => 'SUBN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 57, max => 1, min => 0, pointer => '', tag => 'FILE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 58, max => 1, min => 0, pointer => '', tag => 'COPR', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 60, max => 1, min => 1, pointer => '', tag => 'VERS', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 61, max => 1, min => 1, pointer => '', tag => 'FORM', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 59, max => 1, min => 1, tag => 'GEDC' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 63, max => 1, min => 0, pointer => '', tag => 'VERS', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 62, max => 1, min => 1, pointer => '', tag => 'CHAR', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 64, max => 1, min => 0, pointer => '', tag => 'LANG', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 66, max => 1, min => 1, pointer => '', tag => 'FORM', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 65, max => 1, min => 0, tag => 'PLAC' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 68, max => 'M', min => 0, pointer => '', tag => 'CONT', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+2', line => 69, max => 'M', min => 0, pointer => '', tag => 'CONC', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 67, max => 1, min => 0, pointer => '', tag => 'NOTE', value => '' }, 'Gedcom::Grammar' ) ], level => 0, line => 41, max => 1, min => 1, tag => 'HEAD' }, 'Gedcom::Grammar' ) ], level => -1, line => 39, structure => 'HEADER' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => 0, line => 74, max => 1, min => 1, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 76, max => 1, min => 1, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 78, max => 1, min => 1, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 80, max => 1, min => 1, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 82, max => 1, min => 1, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 84, max => 1, min => 1, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 86, max => 1, min => 1, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => -1, line => 72, selection => 1, structure => 'RECORD' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 92, max => 1, min => 0, pointer => '', tag => 'RESN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 93, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 94, max => 1, min => 0, pointer => 1, tag => 'HUSB', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 95, max => 1, min => 0, pointer => 1, tag => 'WIFE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 96, max => 'M', min => 0, pointer => 1, tag => 'CHIL', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 97, max => 1, min => 0, pointer => '', tag => 'NCHI', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 98, max => 'M', min => 0, pointer => 1, tag => 'SUBM', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 99, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 101, max => 1, min => 0, pointer => '', tag => 'TYPE', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 100, max => 'M', min => 0, pointer => '', tag => 'REFN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 102, max => 1, min => 0, pointer => '', tag => 'RIN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 103, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 104, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 105, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 106, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 91, max => 1, min => 1, tag => 'FAM', xref => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 89, structure => 'FAM_RECORD' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 112, max => 1, min => 0, pointer => '', tag => 'RESN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 113, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 114, max => 1, min => 0, pointer => '', tag => 'SEX', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 115, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 116, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 117, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 118, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 119, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 120, max => 'M', min => 0, pointer => 1, tag => 'SUBM', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 121, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 122, max => 'M', min => 0, pointer => 1, tag => 'ALIA', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 123, max => 'M', min => 0, pointer => 1, tag => 'ANCI', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 124, max => 'M', min => 0, pointer => 1, tag => 'DESI', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 125, max => 1, min => 0, pointer => '', tag => 'RFN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 126, max => 1, min => 0, pointer => '', tag => 'AFN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 128, max => 1, min => 0, pointer => '', tag => 'TYPE', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 127, max => 'M', min => 0, pointer => '', tag => 'REFN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 129, max => 1, min => 0, pointer => '', tag => 'RIN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 130, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 131, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 132, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 133, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 111, max => 1, min => 1, tag => 'INDI', xref => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 109, structure => 'INDIVIDUAL_RECORD' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+3', line => 141, max => 1, min => 0, pointer => '', tag => 'TYPE', value => '' }, 'Gedcom::Grammar' ) ], level => '+2', line => 140, max => 1, min => 1, pointer => '', tag => 'FORM', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 142, max => 1, min => 0, pointer => '', tag => 'TITL', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 139, max => 'M', min => 1, pointer => '', tag => 'FILE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 144, max => 1, min => 0, pointer => '', tag => 'TYPE', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 143, max => 'M', min => 0, pointer => '', tag => 'REFN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 145, max => 1, min => 0, pointer => '', tag => 'RIN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 146, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 147, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 148, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 138, max => 1, min => 1, tag => 'OBJE', xref => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 136, structure => 'MULTIMEDIA_RECORD' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 154, max => 'M', min => 0, pointer => '', tag => 'CONC', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 155, max => 'M', min => 0, pointer => '', tag => 'CONT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 157, max => 1, min => 0, pointer => '', tag => 'TYPE', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 156, max => 'M', min => 0, pointer => '', tag => 'REFN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 158, max => 1, min => 0, pointer => '', tag => 'RIN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 159, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 160, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 153, max => 1, min => 1, pointer => '', tag => 'NOTE', value => '', xref => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 151, structure => 'NOTE_RECORD' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 166, max => 1, min => 1, pointer => '', tag => 'NAME', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 167, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 168, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 170, max => 1, min => 0, pointer => '', tag => 'TYPE', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 169, max => 'M', min => 0, pointer => '', tag => 'REFN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 171, max => 1, min => 0, pointer => '', tag => 'RIN', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 172, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 165, max => 1, min => 1, tag => 'REPO', xref => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 163, structure => 'REPOSITORY_RECORD' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+3', line => 180, max => 1, min => 0, pointer => '', tag => 'DATE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+3', line => 181, max => 1, min => 0, pointer => '', tag => 'PLAC', value => '' }, 'Gedcom::Grammar' ) ], level => '+2', line => 179, max => 'M', min => 0, pointer => '', tag => 'EVEN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 182, max => 1, min => 0, pointer => '', tag => 'AGNC', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 183, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => '+1', line => 178, max => 1, min => 0, tag => 'DATA' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 185, max => 'M', min => 0, pointer => '', tag => 'CONT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 186, max => 'M', min => 0, pointer => '', tag => 'CONC', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 184, max => 1, min => 0, pointer => '', tag => 'AUTH', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 188, max => 'M', min => 0, pointer => '', tag => 'CONT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 189, max => 'M', min => 0, pointer => '', tag => 'CONC', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 187, max => 1, min => 0, pointer => '', tag => 'TITL', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 190, max => 1, min => 0, pointer => '', tag => 'ABBR', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 192, max => 'M', min => 0, pointer => '', tag => 'CONT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 193, max => 'M', min => 0, pointer => '', tag => 'CONC', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 191, max => 1, min => 0, pointer => '', tag => 'PUBL', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 195, max => 'M', min => 0, pointer => '', tag => 'CONT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 196, max => 'M', min => 0, pointer => '', tag => 'CONC', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 194, max => 1, min => 0, pointer => '', tag => 'TEXT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 197, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 199, max => 1, min => 0, pointer => '', tag => 'TYPE', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 198, max => 'M', min => 0, pointer => '', tag => 'REFN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 200, max => 1, min => 0, pointer => '', tag => 'RIN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 201, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 202, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 203, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 177, max => 1, min => 1, tag => 'SOUR', xref => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 175, structure => 'SOURCE_RECORD' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 209, max => 1, min => 0, pointer => 1, tag => 'SUBM', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 210, max => 1, min => 0, pointer => '', tag => 'FAMF', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 211, max => 1, min => 0, pointer => '', tag => 'TEMP', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 212, max => 1, min => 0, pointer => '', tag => 'ANCE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 213, max => 1, min => 0, pointer => '', tag => 'DESC', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 214, max => 1, min => 0, pointer => '', tag => 'ORDI', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 215, max => 1, min => 0, pointer => '', tag => 'RIN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 216, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 217, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 208, max => 1, min => 1, tag => 'SUBN', xref => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 206, structure => 'SUBMISSION_RECORD' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 223, max => 1, min => 1, pointer => '', tag => 'NAME', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 224, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 225, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 226, max => 3, min => 0, pointer => '', tag => 'LANG', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 227, max => 1, min => 0, pointer => '', tag => 'RFN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 228, max => 1, min => 0, pointer => '', tag => 'RIN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 229, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 230, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 222, max => 1, min => 1, tag => 'SUBM', xref => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 220, structure => 'SUBMITTER_RECORD' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 236, max => 3, min => 0, pointer => '', tag => 'CONT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 237, max => 1, min => 0, pointer => '', tag => 'ADR1', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 238, max => 1, min => 0, pointer => '', tag => 'ADR2', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 239, max => 1, min => 0, pointer => '', tag => 'ADR3', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 240, max => 1, min => 0, pointer => '', tag => 'CITY', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 241, max => 1, min => 0, pointer => '', tag => 'STAE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 242, max => 1, min => 0, pointer => '', tag => 'POST', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 243, max => 1, min => 0, pointer => '', tag => 'CTRY', value => '' }, 'Gedcom::Grammar' ) ], level => 0, line => 235, max => 1, min => 0, pointer => '', tag => 'ADDR', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 244, max => 3, min => 0, pointer => '', tag => 'PHON', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 245, max => 3, min => 0, pointer => '', tag => 'EMAIL', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 246, max => 3, min => 0, pointer => '', tag => 'FAX', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 247, max => 3, min => 0, pointer => '', tag => 'WWW', value => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 233, structure => 'ADDRESS_STRUCTURE' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 253, max => 1, min => 1, pointer => '', tag => 'RELA', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 254, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 255, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 252, max => 1, min => 0, pointer => 1, tag => 'ASSO', value => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 250, structure => 'ASSOCIATION_STRUCTURE' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 262, max => 1, min => 0, pointer => '', tag => 'TIME', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 261, max => 1, min => 1, pointer => '', tag => 'DATE', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 263, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 260, max => 1, min => 1, tag => 'CHAN' }, 'Gedcom::Grammar' ) ], level => -1, line => 258, structure => 'CHANGE_DATE' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 269, max => 1, min => 0, pointer => '', tag => 'PEDI', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 270, max => 1, min => 0, pointer => '', tag => 'STAT', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 271, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 268, max => 1, min => 1, pointer => 1, tag => 'FAMC', value => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 266, structure => 'CHILD_TO_FAMILY_LINK' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => 0, line => 276, max => 1, min => 0, pointer => '', tag => 'TYPE', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 277, max => 1, min => 0, pointer => '', tag => 'DATE', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 278, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 279, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 280, max => 1, min => 0, pointer => '', tag => 'AGNC', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 281, max => 1, min => 0, pointer => '', tag => 'RELI', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 282, max => 1, min => 0, pointer => '', tag => 'CAUS', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 283, max => 1, min => 0, pointer => '', tag => 'RESN', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 284, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 285, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 286, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => -1, line => 274, structure => 'EVENT_DETAIL' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 291, max => 1, min => 1, pointer => '', tag => 'AGE', value => '' }, 'Gedcom::Grammar' ) ], level => 0, line => 290, max => 1, min => 0, tag => 'HUSB' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 293, max => 1, min => 1, pointer => '', tag => 'AGE', value => '' }, 'Gedcom::Grammar' ) ], level => 0, line => 292, max => 1, min => 0, tag => 'WIFE' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 294, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => -1, line => 289, structure => 'FAMILY_EVENT_DETAIL' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 301, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 300, max => 1, min => 1, tag => 'ANUL' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 304, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 303, max => 1, min => 1, tag => 'CENS' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 307, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 306, max => 1, min => 1, tag => 'DIV' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 310, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 309, max => 1, min => 1, tag => 'DIVF' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 313, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 312, max => 1, min => 1, tag => 'ENGA' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 316, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 315, max => 1, min => 1, tag => 'MARB' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 319, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 318, max => 1, min => 1, tag => 'MARC' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 322, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 321, max => 1, min => 1, tag => 'MARR' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 325, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 324, max => 1, min => 1, tag => 'MARL' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 328, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 327, max => 1, min => 1, tag => 'MARS' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 331, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 330, max => 1, min => 1, tag => 'RESI' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 334, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 333, max => 1, min => 1, pointer => '', tag => 'EVEN', value => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 297, selection => 1, structure => 'FAMILY_EVENT_STRUCTURE' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 343, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 342, max => 1, min => 1, pointer => '', tag => 'CAST', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 346, max => 'M', min => 0, pointer => '', tag => 'CONT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 347, max => 'M', min => 0, pointer => '', tag => 'CONC', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 348, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 345, max => 1, min => 1, pointer => '', tag => 'DSCR', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 351, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 350, max => 1, min => 1, pointer => '', tag => 'EDUC', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 354, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 353, max => 1, min => 1, pointer => '', tag => 'IDNO', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 357, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 356, max => 1, min => 1, pointer => '', tag => 'NATI', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 360, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 359, max => 1, min => 1, pointer => '', tag => 'NCHI', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 363, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 362, max => 1, min => 1, pointer => '', tag => 'NMR', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 366, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 365, max => 1, min => 1, pointer => '', tag => 'OCCU', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 369, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 368, max => 1, min => 1, pointer => '', tag => 'PROP', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 372, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 371, max => 1, min => 1, pointer => '', tag => 'RELI', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 375, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 374, max => 1, min => 1, tag => 'RESI' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 378, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 377, max => 1, min => 0, pointer => '', tag => 'SSN', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 381, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 380, max => 1, min => 1, pointer => '', tag => 'TITL', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 384, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 383, max => 1, min => 1, pointer => '', tag => 'FACT', value => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 339, selection => 1, structure => 'INDIVIDUAL_ATTRIBUTE_STRUCTURE' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => 0, line => 389, max => 1, min => 1, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 390, max => 1, min => 0, pointer => '', tag => 'AGE', value => '<>' }, 'Gedcom::Grammar' ) ], level => -1, line => 388, structure => 'INDIVIDUAL_EVENT_DETAIL' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 397, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 398, max => 1, min => 0, pointer => 1, selection => 1, tag => 'FAMC', value => '' }, 'Gedcom::Grammar' ) ], level => 0, line => 396, max => 1, min => 1, tag => 'BIRT' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 401, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 402, max => 1, min => 0, pointer => 1, selection => 1, tag => 'FAMC', value => '' }, 'Gedcom::Grammar' ) ], level => 0, line => 400, max => 1, min => 1, tag => 'CHR' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 405, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 404, max => 1, min => 1, tag => 'DEAT' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 408, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 407, max => 1, min => 1, tag => 'BURI' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 411, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 410, max => 1, min => 1, tag => 'CREM' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 414, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+2', line => 416, max => 1, min => 0, pointer => '', selection => 1, tag => 'ADOP', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 415, max => 1, min => 0, pointer => 1, tag => 'FAMC', value => '' }, 'Gedcom::Grammar' ) ], level => 0, line => 413, max => 1, min => 1, tag => 'ADOP' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 419, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 418, max => 1, min => 1, tag => 'BAPM' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 422, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 421, max => 1, min => 1, tag => 'BARM' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 425, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 424, max => 1, min => 1, tag => 'BASM' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 428, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 427, max => 1, min => 1, tag => 'BLES' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 431, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 430, max => 1, min => 1, tag => 'CHRA' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 434, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 433, max => 1, min => 1, tag => 'CONF' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 437, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 436, max => 1, min => 1, tag => 'FCOM' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 440, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 439, max => 1, min => 1, tag => 'ORDN' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 443, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 442, max => 1, min => 1, tag => 'NATU' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 446, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 445, max => 1, min => 1, tag => 'EMIG' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 449, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 448, max => 1, min => 1, tag => 'IMMI' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 452, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 451, max => 1, min => 1, tag => 'CENS' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 455, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 454, max => 1, min => 1, tag => 'PROB' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 458, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 457, max => 1, min => 1, tag => 'WILL' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 461, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 460, max => 1, min => 1, tag => 'GRAD' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 464, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 463, max => 1, min => 1, tag => 'RETI' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 467, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 466, max => 1, min => 1, tag => 'EVEN' }, 'Gedcom::Grammar' ) ], level => -1, line => 393, selection => 1, structure => 'INDIVIDUAL_EVENT_STRUCTURE' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 475, max => 1, min => 0, pointer => '', tag => 'DATE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 476, max => 1, min => 0, pointer => '', tag => 'TEMP', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 477, max => 1, min => 0, pointer => '', tag => 'PLAC', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 479, max => 1, min => 1, pointer => '', tag => 'DATE', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 478, max => 1, min => 0, pointer => '', tag => 'STAT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 480, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 481, max => 'M', min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 474, max => 1, min => 1, tag => 'BAPL' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 484, max => 1, min => 0, pointer => '', tag => 'DATE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 485, max => 1, min => 0, pointer => '', tag => 'TEMP', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 486, max => 1, min => 0, pointer => '', tag => 'PLAC', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 488, max => 1, min => 1, pointer => '', tag => 'DATE', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 487, max => 1, min => 0, pointer => '', tag => 'STAT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 489, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 490, max => 'M', min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 483, max => 1, min => 1, tag => 'CONL' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 493, max => 1, min => 0, pointer => '', tag => 'DATE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 494, max => 1, min => 0, pointer => '', tag => 'TEMP', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 495, max => 1, min => 0, pointer => '', tag => 'PLAC', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 497, max => 1, min => 1, pointer => '', tag => 'DATE', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 496, max => 1, min => 0, pointer => '', tag => 'STAT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 498, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 499, max => 'M', min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 492, max => 1, min => 1, tag => 'ENDL' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 502, max => 1, min => 0, pointer => '', tag => 'DATE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 503, max => 1, min => 0, pointer => '', tag => 'TEMP', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 504, max => 1, min => 0, pointer => '', tag => 'PLAC', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 505, max => 1, min => 1, pointer => 1, tag => 'FAMC', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 507, max => 1, min => 1, pointer => '', tag => 'DATE', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 506, max => 1, min => 0, pointer => '', tag => 'STAT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 508, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 509, max => 'M', min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 501, max => 1, min => 1, tag => 'SLGC' }, 'Gedcom::Grammar' ) ], level => -1, line => 471, selection => 1, structure => 'LDS_INDIVIDUAL_ORDINANCE' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 516, max => 1, min => 0, pointer => '', tag => 'DATE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 517, max => 1, min => 0, pointer => '', tag => 'TEMP', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 518, max => 1, min => 0, pointer => '', tag => 'PLAC', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 520, max => 1, min => 1, pointer => '', tag => 'DATE', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 519, max => 1, min => 0, pointer => '', tag => 'STAT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 521, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 522, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 515, max => 1, min => 1, tag => 'SLGS' }, 'Gedcom::Grammar' ) ], level => -1, line => 513, structure => 'LDS_SPOUSE_SEALING' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => 0, line => 528, max => 1, min => 1, pointer => 1, selection => 1, tag => 'OBJE', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+3', line => 533, max => 1, min => 0, pointer => '', tag => 'TYPE', value => '' }, 'Gedcom::Grammar' ) ], level => '+2', line => 532, max => 1, min => 1, pointer => '', tag => 'FORM', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+2', line => 534, max => 1, min => 0, pointer => '', selection => 1, tag => 'TITL', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 531, max => 'M', min => 1, pointer => '', tag => 'FILE', value => '' }, 'Gedcom::Grammar' ) ], level => 0, line => 530, max => 1, min => 1, tag => 'OBJE' }, 'Gedcom::Grammar' ) ], level => -1, line => 525, selection => 1, structure => 'MULTIMEDIA_LINK' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => 0, line => 541, max => 1, min => 1, pointer => 1, selection => 1, tag => 'NOTE', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 544, max => 'M', min => 0, pointer => '', tag => 'CONC', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 545, max => 'M', min => 0, pointer => '', selection => 1, tag => 'CONT', value => '' }, 'Gedcom::Grammar' ) ], level => 0, line => 543, max => 1, min => 1, pointer => '', tag => 'NOTE', value => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 538, selection => 1, structure => 'NOTE_STRUCTURE' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => 0, line => 551, max => 1, min => 0, pointer => '', tag => 'NPFX', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 552, max => 1, min => 0, pointer => '', tag => 'GIVN', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 553, max => 1, min => 0, pointer => '', tag => 'NICK', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 554, max => 1, min => 0, pointer => '', tag => 'SPFX', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 555, max => 1, min => 0, pointer => '', tag => 'SURN', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 556, max => 1, min => 0, pointer => '', tag => 'NSFX', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 557, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 558, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => -1, line => 549, structure => 'PERSONAL_NAME_PIECES' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 564, max => 1, min => 0, pointer => '', tag => 'TYPE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 565, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 567, max => 1, min => 1, pointer => '', tag => 'TYPE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 568, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => '+1', line => 566, max => 'M', min => 0, pointer => '', tag => 'FONE', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 570, max => 1, min => 1, pointer => '', tag => 'TYPE', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+2', line => 571, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => '+1', line => 569, max => 'M', min => 0, pointer => '', tag => 'ROMN', value => '' }, 'Gedcom::Grammar' ) ], level => 0, line => 563, max => 1, min => 1, pointer => '', tag => 'NAME', value => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 561, structure => 'PERSONAL_NAME_STRUCTURE' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 577, max => 1, min => 0, pointer => '', tag => 'FORM', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 579, max => 1, min => 1, pointer => '', tag => 'TYPE', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 578, max => 'M', min => 0, pointer => '', tag => 'FONE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 581, max => 1, min => 1, pointer => '', tag => 'TYPE', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 580, max => 'M', min => 0, pointer => '', tag => 'ROMN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 583, max => 1, min => 1, pointer => '', tag => 'LATI', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 584, max => 1, min => 1, pointer => '', tag => 'LONG', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 582, max => 1, min => 0, tag => 'MAP' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 585, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 576, max => 1, min => 1, pointer => '', tag => 'PLAC', value => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 574, structure => 'PLACE_STRUCTURE' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 592, max => 1, min => 0, pointer => '', tag => 'PAGE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 594, max => 1, min => 0, pointer => '', tag => 'ROLE', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 593, max => 1, min => 0, pointer => '', tag => 'EVEN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 596, max => 1, min => 0, pointer => '', tag => 'DATE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+3', line => 598, max => 'M', min => 0, pointer => '', tag => 'CONC', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+3', line => 599, max => 'M', min => 0, pointer => '', tag => 'CONT', value => '' }, 'Gedcom::Grammar' ) ], level => '+2', line => 597, max => 'M', min => 0, pointer => '', tag => 'TEXT', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 595, max => 1, min => 0, tag => 'DATA' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 600, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 601, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 602, max => 1, min => 0, pointer => '', selection => 1, tag => 'QUAY', value => '' }, 'Gedcom::Grammar' ) ], level => 0, line => 591, max => 1, min => 1, pointer => 1, tag => 'SOUR', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 605, max => 'M', min => 0, pointer => '', tag => 'CONC', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 606, max => 'M', min => 0, pointer => '', tag => 'CONT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 608, max => 'M', min => 0, pointer => '', tag => 'CONC', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 609, max => 'M', min => 0, pointer => '', tag => 'CONT', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 607, max => 'M', min => 0, pointer => '', tag => 'TEXT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 610, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 611, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 612, max => 1, min => 0, pointer => '', selection => 1, tag => 'QUAY', value => '' }, 'Gedcom::Grammar' ) ], level => 0, line => 604, max => 1, min => 1, pointer => '', tag => 'SOUR', value => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 588, selection => 1, structure => 'SOURCE_CITATION' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 619, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+2', line => 621, max => 1, min => 0, pointer => '', tag => 'MEDI', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 620, max => 'M', min => 0, pointer => '', tag => 'CALN', value => '' }, 'Gedcom::Grammar' ) ], level => 0, line => 618, max => 1, min => 1, pointer => 1, tag => 'REPO', value => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 616, structure => 'SOURCE_REPOSITORY_CITATION' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 628, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 627, max => 1, min => 1, pointer => 1, tag => 'FAMS', value => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 625, structure => 'SPOUSE_TO_FAMILY_LINK' }, 'Gedcom::Grammar' ) ], level => -2, line => 0, stored_item => undef, version => '5.5.1' }, 'Gedcom::Grammar' ); Gedcom-1.19/lib/Gedcom/Individual.pm0000644000175000017500000002252512204002474015673 0ustar pjcjpjcj# Copyright 1999-2013, Paul Johnson (paul@pjcj.net) # 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::Individual; use Gedcom::Record 1.19; use vars qw($VERSION @ISA); $VERSION = "1.19"; @ISA = qw( Gedcom::Record ); sub name { my $self = shift; my $name = $self->tag_value("NAME"); return "" unless defined $name; $name =~ s/\s+/ /g; $name =~ s| ?/ ?(.*?) ?/ ?| /$1/ |; $name =~ s/^\s+//g; $name =~ s/\s+$//g; $name } sub cased_name { my $self = shift; my $name = $self->name; $name =~ s|/([^/]*)/?|uc $1|e; $name } sub surname { my $self = shift; my ($surname) = $self->name =~ m|/([^/]*)/?|; $surname || "" } sub given_names { my $self = shift; my $name = $self->name; $name =~ s|/([^/]*)/?| |; $name =~ s|^\s+||; $name =~ s|\s+$||; $name =~ s|\s+| |g; $name } sub soundex { my $self = shift; unless ($INC{"Text/Soundex.pm"}) { warn "Text::Soundex.pm is required to use soundex()"; return undef } Gedcom::soundex($self->surname) } sub sex { my $self = shift; my $sex = $self->tag_value("SEX"); if(defined $sex){ $sex =~ /^F/i ? "F" : $sex =~ /^M/i ? "M" : "U"; }else{ "U"; } } sub father { my $self = shift; my @a = map { $_->husband } $self->famc; wantarray ? @a : $a[0] } sub mother { my $self = shift; my @a = map { $_->wife } $self->famc; wantarray ? @a : $a[0] } sub parents { my $self = shift; ($self->father, $self->mother) } sub husband { my $self = shift; my @a = grep { $_->{xref} ne $self->{xref} } map { $_->husband } $self->fams; wantarray ? @a : $a[0] } sub wife { my $self = shift; my @a = grep { $_->{xref} ne $self->{xref} } map { $_->wife } $self->fams; wantarray ? @a : $a[0] } sub spouse { my $self = shift; my @a = ($self->husband, $self->wife); wantarray ? @a : $a[0] } sub siblings { my $self = shift; my @a = grep { $_->{xref} ne $self->{xref} } map { $_->children } $self->famc; wantarray ? @a : $a[0] } sub half_siblings { my $self = shift; my @all_siblings_multiple = map { $_->children } ( map { $_->fams } $self->parents ); my @excludelist = ($self, $self->siblings); my @a = grep { my $cur = $_; my $half_sibling=1; foreach my $test(@excludelist){ if($cur->{xref} eq $test->{xref} ){ $half_sibling=0; last; } } push @excludelist, $cur if($half_sibling); # in order to avoid multiple output $half_sibling; } @all_siblings_multiple; wantarray ? @a : $a[0] } sub older_siblings { my $self = shift; my @a = map { $_->children } $self->famc; my $i; for ($i = 0; $i <= $#a; $i++) { last if $a[$i]->{xref} eq $self->{xref} } splice @a, $i; wantarray ? @a : $a[-1] } sub younger_siblings { my $self = shift; my @a = map { $_->children } $self->famc; my $i; for ($i = 0; $i <= $#a; $i++) { last if $a[$i]->{xref} eq $self->{xref} } splice @a, 0, $i + 1; wantarray ? @a : $a[0] } sub brothers { my $self = shift; my @a = grep { $_->tag_value("SEX") !~ /^F/i } $self->siblings; wantarray ? @a : $a[0] } sub half_brothers { my $self = shift; my @a = grep { $_->tag_value("SEX") !~ /^F/i } $self->half_siblings; wantarray ? @a : $a[0] } sub sisters { my $self = shift; my @a = grep { $_->tag_value("SEX") !~ /^M/i } $self->siblings; wantarray ? @a : $a[0] } sub half_sisters { my $self = shift; my @a = grep { $_->tag_value("SEX") !~ /^M/i } $self->half_siblings; wantarray ? @a : $a[0] } sub children { my $self = shift; my @a = map { $_->children } $self->fams; wantarray ? @a : $a[0] } sub sons { my $self = shift; my @a = grep { $_->tag_value("SEX") !~ /^F/i } $self->children; wantarray ? @a : $a[0] } sub daughters { my $self = shift; my @a = grep { $_->tag_value("SEX") !~ /^M/i } $self->children; wantarray ? @a : $a[0] } sub descendents { my $self = shift; my @d; my @c = $self->children; while (@c) { push @d, @c; @c = map { $_->children } @c; } @d } sub ancestors { my $self = shift; my @d; my @c = $self->parents; while (@c) { push @d, @c; @c = map { $_->parents } @c; } @d } sub delete { my $self = shift; my $xref = $self->{xref}; my $ret = 1; for my $f ( [ "(HUSB|WIFE)", [$self->fams] ], [ "CHIL", [$self->famc] ] ) { for my $fam (@{$f->[1]}) { # print "deleting from $fam->{xref}\n"; for my $record (@{$fam->_items}) { # print "looking at $record->{tag} $record->{value}\n"; if (($record->{tag} =~ /$f->[0]/) && $self->resolve($record->{value})->{xref} eq $xref) { $ret = 0 unless $fam->delete_record($record); } } $self->{gedcom}{record}->delete_record($fam) unless $fam->tag_value("HUSB") || $fam->tag_value("WIFE") || $fam->tag_value("CHIL"); # TODO - write Family::delete ? # - delete associated notes? } } $ret = 0 unless $self->{gedcom}{record}->delete_record($self); $_[0] = undef if $ret; # Can't reuse a deleted person $ret } sub print { my $self = shift; $self->_items if shift; $self->SUPER::print; $_->print for @{$self->{items}}; # print "fams:\n"; $_->print for $self->fams; # print "famc:\n"; $_->print for $self->famc; } sub print_generations { my $self = shift; my ($generations, $indent) = @_; $generations = 0 unless $generations; $indent = 0 unless $indent; 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) { # $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"; } for my $child ($fam->children) { print "$i> $child->{xref} (", $child->rin, ") ", $child->name, "\n"; $child->print_generations($generations - 1, $indent + 1); } } } sub famc { my $self = shift; my @a = $self->resolve($self->tag_value("FAMC")); wantarray ? @a : $a[0] } sub fams { my $self = shift; my @a = $self->resolve($self->tag_value("FAMS")); wantarray ? @a : $a[0] } 1; __END__ =head1 NAME Gedcom::Individual - a module to manipulate Gedcom individuals Version 1.19 - 18th August 2013 =head1 SYNOPSIS use Gedcom::Individual; my $name = $i->name; my $cased_name = $i->cased_name; my $surname = $i->surname; my $given_names = $i->given_names; my $soundex = $i->soundex; my $sex = $i->sex; my @rel = $i->father; my @rel = $i->mother; my @rel = $i->parents; my @rel = $i->husband; my @rel = $i->wife; my @rel = $i->spouse; my @rel = $i->siblings; my @rel = $i->half_siblings; my @rel = $i->brothers; my @rel = $i->half_brothers; my @rel = $i->sisters; my @rel = $i->half_sisters; my @rel = $i->children; my @rel = $i->sons; my @rel = $i->daughters; my @rel = $i->descendents; my @rel = $i->ancestors; my $ok = $i->delete; my @fam = $i->famc; my @fam = $i->fams; =head1 DESCRIPTION A selection of subroutines to handle individuals in a gedcom file. Derived from Gedcom::Record. =head1 HASH MEMBERS None. =head1 METHODS =head2 name my $name = $i->name; Return the name of the individual, with spaces normalised. =head2 cased_name my $cased_name = $i->cased_name; Return the name of the individual, with spaces normalised, and surname in upper case. =head2 surname my $surname = $i->surname; Return the surname of the individual. =head2 given_names my $given_names = $i->given_names; Return the given names of the individual, with spaces normalised. =head2 soundex my $soundex = $i->soundex; Return the soundex code of the individual. This function is only available if I is available. =head2 sex my $sex = $i->sex; Return the sex of the individual, "M", "F" or "U". =head2 Individual functions my @rel = $i->father; my @rel = $i->mother; my @rel = $i->parents; my @rel = $i->husband; my @rel = $i->wife; my @rel = $i->spouse; my @rel = $i->siblings; my @rel = $i->half_siblings; my @rel = $i->older_siblings; my @rel = $i->younger_siblings; my @rel = $i->brothers; my @rel = $i->half_brothers; my @rel = $i->sisters; my @rel = $i->half_sisters; my @rel = $i->children; my @rel = $i->sons; my @rel = $i->daughters; my @rel = $i->descendents; my @rel = $i->ancestors; Return a list of individuals related to $i. Each function, even those with a singular name such as father(), returns a list of individuals holding that relation to $i. More complex relationships can easily be found using the map function. eg: my @grandparents = map { $_->parents } $i->parents; =head2 delete my $ok = $i->delete; 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 if $i was successfully deleted. =head2 Family functions my @fam = $i->famc; my @fam = $i->fams; Return a list of families to which $i belongs. famc() returns those families in which $i is a child. fams() returns those families in which $i is a spouse. =cut Gedcom-1.19/lib/Gedcom/CGI.pm0000644000175000017500000000647412204002473014211 0ustar pjcjpjcj# Copyright 2001-2013, Paul Johnson (paul@pjcj.net) # 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::CGI; use CGI qw(:cgi :html); use Gedcom 1.19; use vars qw($VERSION); $VERSION = "1.19"; sub gedcom { my ($gedcom_file) = @_; $gedcom_file = "/var/www/Gedcom/$gedcom_file.ged"; Gedcom->new(gedcom_file => $gedcom_file, read_only => 1); } sub dates { my ($i) = @_; "(" . ($i->get_value("birth date") || "") . " - " . ($i->get_value("death date") || "") . ")" } sub indi_link { my ($g, $i) = @_; return p("Unknown") unless $i; p( a({-href => "/cgi-bin/gedcom.cgi?op=indi&gedcom=$g&indi=" . $i->xref}, $i->cased_name) . " " . dates($i) ) } sub main { my $gedcom = param("gedcom"); my $ged = gedcom($gedcom); print header, start_html, h1($gedcom), map(indi_link($gedcom, $_), $ged->individuals), end_html; } sub event_row { my ($n, @e) = @_; map { td ([ $n, $_->get_value("date") || "-", $_->get_value("place") || "-", ]) } @e } sub indi_row { my ($g, $n, @i) = @_; map { td ([ $n, a({-href => "/cgi-bin/gedcom.cgi?op=indi&gedcom=$g&indi=" . $_->xref}, $_->cased_name), $_->get_value("birth date") || "-", $_->get_value("death date") || "-", ]) } @i } sub indi { my $gedcom = param("gedcom"); my $indi = param("indi"); my $ged = gedcom($gedcom); my $i = $ged->get_individual($indi); my $name = $i->cased_name; my $sex = uc $i->sex; my $spouse = $sex eq "M" ? "wife" : $sex eq "F" ? "husband" : "spouse"; print header, start_html(-title => $name), h1($name), table ( { -border => undef }, Tr ( { align => "CENTER", valign => "TOP" }, [ 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))), ] ) ), p, table ( { -border => undef }, Tr ( { align => "CENTER", valign => "TOP" }, [ th([ "Relation", "Name", "Birth", "Death"]), indi_row($gedcom, ucfirst $spouse ,$i->$spouse()), indi_row($gedcom, "Father", $i->father), indi_row($gedcom, "Mother", $i->mother), indi_row($gedcom, "Child", $i->children), ] ) ), p(a({-href => "/cgi-bin/gedcom.cgi?op=main&gedcom=$gedcom"}, $gedcom)), end_html; } 1; __END__ =head1 NAME Gedcom::CGI - Basic CGI routines for Gedcom.pm Version 1.19 - 18th August 2013 =head1 SYNOPSIS use Gedcom::CGI; =head1 DESCRIPTION =head1 METHODS =cut Gedcom-1.19/lib/Gedcom/Event.pm0000644000175000017500000000173312204002473014661 0ustar pjcjpjcj# Copyright 1999-2013, Paul Johnson (paul@pjcj.net) # 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::Event; use Gedcom::Record 1.19; use vars qw($VERSION @ISA); $VERSION = "1.19"; @ISA = qw( Gedcom::Record ); # sub type # { # my $self = shift; # $self->tag_value("TYPE") # } # sub date # { # my $self = shift; # $self->tag_value("DATE") # } # sub place # { # my $self = shift; # $self->tag_value("PLAC") # } 1; __END__ =head1 NAME Gedcom::Event - a module to manipulate Gedcom events Version 1.19 - 18th August 2013 =head1 SYNOPSIS use Gedcom::Event; =head1 DESCRIPTION A selection of subroutines to handle events in a gedcom file. Derived from Gedcom::Record. =head1 HASH MEMBERS None. =head1 METHODS None yet. =head2 Individual functions =cut Gedcom-1.19/lib/Gedcom/LifeLines.pm0000644000175000017500000004726612204002474015466 0ustar pjcjpjcj# Copyright 1999-2013, Paul Johnson (paul@pjcj.net) # 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::LifeLines; use Exporter; BEGIN { # We'll use these if they are available eval "use Date::Manip"; eval "use Roman ()"; } use Gedcom 1.19; use vars qw($VERSION @ISA @EXPORT); $VERSION = "1.19"; @ISA = qw( Exporter ); @EXPORT = qw ( set_ged display flush name fullname surname givens trimname birth death baptism burial father mother nextsib prevsib sex male female pn nspouses nfamilies parents title key soundex inode root indi firstindi nextindi previndi marriage husband wife nchildren firstchild lastchild fnode fam firstfam nextfam prevfam xref tag value parent child sibling savenode date place year long short gettoday dayformat monthformat dateformat stddate extractdate extractnames extractplaces extracttokens getindi getindiset getfam getint getstr getindimsg getintmsg getstrmsg choosechild choosefam chooseindi choosesubset menuchoose lower upper capitalize trim rjustify save strsave concat strconcat strlen substring index d card ord alpha roman strsoundex strtoint atoi strcmp eqstr nestr linemode pagemode col row pos pageout nl sp qt newfile outfile copyfile print addtoset deletefromset lengthset union intersect difference parentset childset spouseset siblingset ancestorset descendentset descendantset uniqueset namesort keysort valuesort genindiset gengedcom createnode addnode deletenode reference dereference getrecord lock unlock database version system ); my ($Day_format, $Month_format, $Date_format) = (0, 0, 0); my ($Line_mode, $Rows, $Columns, $Row, $Column) = (1, 0, 0, 0, 0); my ($Line, @Lines) = (""); my $Ged; sub set_ged { $Ged = shift } sub display { my ($text) = @_; return unless defined $text && length $text; if ($Line_mode) { $Line .= $text; print $1 if $Line =~ s/^(.*\n)//s; } else { # print STDERR "$Row, $Column: <$text>\n"; $Lines[$Row] .= " " x ($Column - length $Lines[$Row]); substr $Lines[$Row], $Column, length $text, $text; $Column += length $text; } return } sub flush { if ($Line_mode) { print $Line; $Line = ""; } else { pageout(); } return } sub name { my ($indi, $cased) = @_; return unless $indi; my $name = !defined $cased || $cased ? $indi->cased_name : $indi->name; $name =~ s|/||g; $name } sub fullname { my ($indi, $cased, $inorder, $length) = @_; return unless $indi; my $name = $inorder ? name($indi, $cased) : ($cased ? uc $indi->surname : $indi->surname) . ", " . $indi->given_names; $name = substr $name, 0, $length if defined $length; $name } sub surname { my ($indi) = @_; return unless $indi; $indi->surname } sub givens { my ($indi) = @_; return unless $indi; $indi->given_names } sub trimname { my ($indi, $length) = @_; return unless $indi; substr $indi->name, 0, $length } sub birth { my ($indi) = @_; return unless $indi; $indi->tag_record("BIRT") } sub death { my ($indi) = @_; return unless $indi; $indi->tag_record("DEAT") } sub baptism { my ($indi) = @_; return unless $indi; $indi->tag_record("BAPM") || $indi->tag_record("BAPL") || $indi->tag_record("CHR") || $indi->tag_record("CHRA") } sub burial { my ($indi) = @_; return unless $indi; $indi->tag_record("BURI") } sub father { my ($indi) = @_; return undef unless $indi; scalar $indi->father } sub mother { my ($indi) = @_; return undef unless $indi; scalar $indi->mother } sub nextsib { my ($indi) = @_; return undef unless $indi; scalar $indi->younger_siblings } sub prevsib { my ($indi) = @_; return undef unless $indi; scalar $indi->older_siblings } sub sex { my ($indi) = @_; return unless $indi; $indi->sex } sub male { my ($indi) = @_; return unless $indi; $indi->sex eq "M" } sub female { my ($indi) = @_; return unless $indi; $indi->sex eq "F" } sub pn { my ($indi, $type) = @_; return unless $indi; (qw(He She he she His Her his her him her))[$type * 2 + ($indi->sex eq "F" ? 1 : 0)] } sub nspouses { my ($indi) = @_; return unless $indi; my @a = $indi->spouse; scalar @a } sub nfamilies { my ($indi) = @_; return unless $indi; my @a = $indi->fams; scalar @a } sub parents { my ($indi) = @_; return unless $indi; my $a = $indi->famc; $a } sub title { my ($indi) = @_; return unless $indi; $indi->tag_value("TITL") } sub key { my ($record, $type) = @_; return unless $record; my $key = $record->xref; $key =~ s/^[a-z]*//i if $type; $key } sub soundex { my ($indi) = @_; return unless $indi; $indi->soundex } sub inode { my ($indi) = @_; $indi; } sub root { my ($record) = @_; $record; } sub indi { my ($name) = @_; $Ged->get_individual($name) } sub firstindi { (sort { key($a, 1) <=> key($b, 1) } $Ged->individuals)[0] } sub nextindi { my ($indi) = @_; return unless $indi; my @a = sort { key($a, 1) <=> key($b, 1) } $Ged->individuals; my $i; for ($i = 0; $i <= $#a; $i++) { last if $a[$i]->{xref} eq $indi->{xref} } splice @a, 0, $i + 1; wantarray ? @a : $a[0] } sub previndi { my ($indi) = @_; return unless $indi; my @a = sort { key($a, 1) <=> key($b, 1) } $Ged->individuals; my $i; for ($i = 0; $i <= $#a; $i++) { last if $a[$i]->{xref} eq $indi->{xref} } splice @a, $i; wantarray ? @a : $a[-1] } sub marriage { my ($fam) = @_; return unless $fam; $fam->marr } sub husband { my ($fam) = @_; return undef unless $fam; scalar $fam->husband } sub wife { my ($fam) = @_; return undef unless $fam; scalar $fam->wife } sub nchildren { my ($fam) = @_; return unless $fam; $fam->number_of_children } sub firstchild { my ($fam) = @_; return undef unless $fam; scalar $fam->children } sub lastchild { my ($fam) = @_; return undef unless $fam; scalar $fam->children } sub fnode { my ($fam) = @_; $fam; } sub fam { my ($xref) = @_; $Ged->resolve_xref($xref) } sub firstfam { (sort { key($a, 1) <=> key($b, 1) } $Ged->families)[0] } sub nextfam { my ($fam) = @_; return unless $fam; my @a = sort { key($a, 1) <=> key($b, 1) } $Ged->families; my $i; for ($i = 0; $i <= $#a; $i++) { last if $a[$i]->{xref} eq $fam->{xref} } splice @a, 0, $i + 1; wantarray ? @a : $a[0] } sub prevfam { my ($fam) = @_; return unless $fam; my @a = sort { key($a, 1) <=> key($b, 1) } $Ged->families; my $i; for ($i = 0; $i <= $#a; $i++) { last if $a[$i]->{xref} eq $fam->{xref} } splice @a, $i; wantarray ? @a : $a[-1] } sub xref { my ($record) = @_; return unless $record; $record->xref } sub tag { my ($record) = @_; return unless $record; $record->tag } sub value { my ($record) = @_; return unless $record; $record->full_value } sub parent { my ($record) = @_; return unless $record; $record->parent } sub child { my ($record) = @_; return unless $record; $record->_items()->[0] } sub sibling { my ($record) = @_; return unless $record; 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 { my ($record) = @_; return unless $record; $record->copy } sub date { my ($event) = @_; return unless $event; $event->date || "" } sub place { my ($event) = @_; return unless $event; $event->place || "" } sub year { my ($event) = @_; return unless $event; $event->date =~ /(\d{3,4})/; $1 || ""; } sub long { my ($event) = @_; return unless $event; date($event) . ", " . place($event) } sub short { my ($event) = @_; return unless $event; year($event) . ", " . ((split(/,\s*/, place($event)))[-1] || "") } sub gettoday { my $event = Gedcom::Event->new(gedcom => $Ged); $event->add("date", uc join " ", (localtime)[2, 1, 4]) } sub dayformat { $Day_format = shift || 0; return; } sub monthformat { $Month_format = shift || 0; return; } sub dateformat { $Date_format = shift || 0; return; } sub stddate { my ($event) = @_; my $date = date($event); return "" unless $date; unless ($INC{"Date/Manip.pm"}) { warn "Date::Manip.pm is required to use stddate()"; return $date; } my $dt = ParseDate($date); my $d = UnixDate($dt, $Day_format == 1 ? "%d" : "%e"); $d = int $d if $Day_format == 2; my $m = UnixDate($dt, $Month_format > 4 ? "%B" : $Month_format > 2 ? "%b" : $Month_format == 1 ? "%m" : "%f"); $m = int $m if $Month_format == 2; $m = uc $m if $Month_format == 3 || $Month_format == 5; my $y = UnixDate($dt, "%Y"); ( "$d $m $y", "$m $d, $y", "$m/$d/$y", "$d/$m/$y", "$m-$d-$y", "$d-$m-$y", "$m$d$y", "$d$m$y", "$y $m $d", "$y/$m/$d", "$y-$m-$d", "$y$m$d", )[$Date_format] } sub extractdate { my $record = shift; return unless $record; my $d = \shift; my $m = \shift; my $y = \shift; $$d = $$m = $$y = 0; my $date = $record->tag eq "DATE" ? $record->full_value : $record->date; return unless $date; unless ($INC{"Date/Manip.pm"}) { warn "Date::Manip.pm is required to use extractdate()"; return; } my $dt = ParseDate($date); return unless $dt; $$d = int UnixDate($dt, "%e"); $$m = int UnixDate($dt, "%f"); $$y = int UnixDate($dt, "%Y"); return } sub extractnames { my $record = shift; my $names = \shift; my $count = \shift; my $surname = \shift; $$names = []; $$count = $$surname = 0; my $name = $record->tag eq "NAME" ? $record->full_value : $record->name; return unless $name; 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 } sub extractplaces { my $record = shift; my $places = \shift; my $count = \shift; $$places = []; $$count = 0; my $place = $record->tag eq "PLACE" ? $record->full_value : $record->place; return unless $place; @$$places = split /\s*,\s*/, $place; $$count = scalar @$$places; return } sub extracttokens { my $string = shift; my $tokens = \shift; my $count = \shift; my $delimiters = shift; $$tokens = []; $$count = 0; return unless $string; @$$tokens = split /[\Q$delimiters\E]/, $string; $$count = scalar @$$tokens; return } sub getindi { my $indi = \shift; my $string = shift || "Please specify an individual"; print STDERR $string, " "; my $i = ; chomp $i; # print "looking for $i\n"; $$indi = indi($i); # print "found $$indi - ", $$indi->name, "\n"; return } sub getindimsg { getindi(@_) } sub getindiset { die "LifeLines getindiset function not yet implemented" } sub getfam { my $fam = \shift; my $string = shift || "Please enter a family:"; print STDERR $string, " "; my $f = ; chomp $f; $$fam = $Ged->resolve_xref($f) || $Ged->resolve_xref(uc $f) || $Ged->resolve_xref("F$f"); return } sub getint { my $number = \shift; my $string = shift || "Please enter an integer:"; print STDERR $string, " "; $$number = ; chomp $$number; return } sub getintmsg { getint(@_) } sub getstr { my $str = \shift; my $string = shift || "Please enter a string:"; print STDERR $string, " "; $$str = ; return } sub getstrmsg { getstr(@_) } sub choosechild { die "LifeLines choosechild function not yet implemented" } sub choosefam { die "LifeLines choosefam function not yet implemented" } sub chooseindi { die "LifeLines chooseindi function not yet implemented" } sub choosesubset { die "LifeLines choosesubset function not yet implemented" } sub menuchoose { die "LifeLines menuchoose function not yet implemented" } sub lower { my ($string) = @_; lc $string } sub upper { my ($string) = @_; uc $string } sub capitalize { my $string = \shift; $$string = ucfirst $$string } sub trim { my ($string, $length) = @_; substr $string, 0, $length } sub rjustify { my ($string, $length) = @_; $string = substr $string, 0, $length; " " x ($length - length $string) . $string } sub save { my ($string) = @_; $string } sub strsave { my ($string) = @_; $string } sub concat { join "", @_ } sub strconcat { join "", @_ } sub strlen { my ($string) = @_; length $string } sub substring { my ($string, $start, $end) = @_; 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 + 1 } sub d { my ($number) = @_; $number ? int $number : 0 } sub card { my ($number) = @_; 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) = @_; 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 { my ($number) = @_; chr CORE::ord 'a' - $number } sub roman { my ($number) = @_; unless ($INC{"Roman.pm"}) { warn "Roman.pm is required to use roman()"; return $number; } Roman::roman($number) } sub strsoundex { my ($string) = @_; Gedcom::soundex($string) } sub strtoint { my ($string) = @_; local $^W; int $string } sub atoi { strtoint(@_) } sub strcmp { my ($string1, $string2) = @_; $string1 cmp $string2 } sub eqstr { my ($string1, $string2) = @_; $string1 eq $string2 } sub nestr { my ($string1, $string2) = @_; $string1 ne $string2 } sub linemode { $Line_mode = 1; return } sub pagemode { my ($rows, $columns) = @_; $Line_mode = 0; $Rows = $rows || 0; $Columns = $columns || 0; $#Lines = $Rows; $Lines[$_] = "" for 0..$Rows - 1; return } sub col { my ($column) = @_; $column--; if ($Line_mode) { display(length $Line > $column ? "\n" . " " x $column : " " x ($column - length $Line)) } else { $Column = $column } return } sub row { my ($row) = @_; unless ($Line_mode) { $Row = $row - 1; $Column = 0; } return } sub pos { my ($row, $column) = @_; ($Row, $Column) = ($row - 1, $column - 1) unless $Line_mode; return } sub pageout { # print join "\n", map { substr($_, 0, $Columns) } @Lines[0..$Rows - 1]; print substr($Lines[$_], 0, $Columns), "\n" for 0..$Rows - 1; $Lines[$_] = "" for 0..$Rows - 1; $Row = $Column = 0; return } sub nl { "\n" } sub sp { " " } sub qt { '"' } { my $Openfile; 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 { my ($file) = @_; $file = "$ENV{LLPROGRAMS}/$file" unless -e $file; unless (open(F, $file)) { warn "Error: Cannot open file $file in copyfile: $!"; return; } print while ; close F or warn "Error: Cannot close file $file in copyfile: $!"; } sub print { print STDERR @_; return } sub addtoset { my ($set, $indi, $data) = @_; push @$set, [$indi, $data]; return } sub deletefromset { my ($set, $indi, $all) = @_; my $count = 0; my @new = grep { my $keep = ($count && !$all) || $_->[0] ne $indi; $count++ unless $keep; $keep } @$set; $_[0] = \@new; return } sub lengthset { my ($set) = @_; scalar @$set } sub union { my ($s1, $s2) = @_; my %s; for my $e (@$s1, @$s2) { $s{$e->[0]} = $e->[1] unless exists $s{$e->[0]} } my @s; while (my ($indi, $data) = each %s) { push @s, [$indi, $data] } \@s } sub intersect { my ($s1, $s2) = @_; my (%s1, %s2); for my $e (@$s1) { $s1{$e->[0]} = $e->[1] unless exists $s1{$e->[0]} } for my $e (@$s2) { $s2{$e->[0]} = $e->[1] unless exists $s2{$e->[0]} } my @s; while (my ($indi, $data) = each %s1) { push @s, [$indi, $data] if exists $s2{$indi} } \@s } sub difference { my ($s1, $s2) = @_; my (%s1, %s2); for my $e (@$s1) { $s1{$e->[0]} = $e->[1] unless exists $s1{$e->[0]} } for my $e (@$s2) { $s2{$e->[0]} = $e->[1] unless exists $s2{$e->[0]} } my @s; while (my ($indi, $data) = each %s1) { push @s, [$indi, $data] unless exists $s2{$indi} } \@s } sub parentset { my ($set) = @_; [ map { my ($i, $d) = @$_; map { [ $_ => $d ] } $i->parents } @$set ] } sub childset { my ($set) = @_; [ map { my ($i, $d) = @$_; map { [ $_ => $d ] } $i->children } @$set ] } sub spouseset { my ($set) = @_; [ map { my ($i, $d) = @$_; map { [ $_ => $d ] } $i->spouse } @$set ] } sub siblingset { my ($set) = @_; [ map { my ($i, $d) = @$_; map { [ $_ => $d ] } $i->siblings } @$set ] } sub ancestorset { my ($set) = @_; # TODO - set the data appropriately [ map { my $c = $_->[0]; map { [ $_ => 0 ] } $c->ancestors } @$set ] } sub descendentset { my ($set) = @_; # TODO - set the data appropriately [ map { my $c = $_->[0]; map { [ $_ => 0 ] } $c->descendents } @$set ] } sub descendantset { descendentset(@_) } sub uniqueset { my ($set) = @_; union($set, []) } sub namesort { my ($set) = @_; @$set = sort { fullname($a->[0]) cmp fullname($b->[0]) } @$set; return } sub keysort { my ($set) = @_; @$set = sort { key($a->[0]) cmp key($b->[0]) } @$set; return } sub valuesort { my ($set) = @_; # TODO - should this be cmp? @$set = sort { $a->[1] <=> $b->[1] } @$set; return } sub genindiset { my $name = shift; my $set = \shift; $$set = [ map { $_ => 0 } $Ged->get_individual($name) ]; return } sub gengedcom { my ($set) = @_; die "LifeLines gengedcom function not yet implemented" } sub createnode { die "LifeLines createnode function not yet implemented" } sub addnode { die "LifeLines addnode function not yet implemented" } sub deletenode { die "LifeLines deletenode function not yet implemented" } sub reference { my ($ref) = @_; $Ged->resolve_xref($ref) } sub dereference { my ($ref) = @_; $Ged->resolve_xref($ref) } sub getrecord { dereference(@_) } sub lock { return } sub unlock { return } sub database { $Ged->{file} } sub version { $VERSION } sub system { system(@_) } 1; __END__ =head1 NAME Gedcom::LifeLines - functions for lines2perl Version 1.19 - 18th August 2013 =head1 SYNOPSIS use Gedcom::LifeLines; =head1 DESCRIPTION A selection of subroutines to emulate Lifelines functions. For details about the functions, see the Lifelines documentation. I general, this module should only be used by the output of the 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: sibling() getindiset() choosechild() choosefam() chooseindi() choosesubset() menuchoose() gengedcom() createnode() addnode() deletenode() =cut Gedcom-1.19/lib/Gedcom/WebServices.pm0000644000175000017500000002261112204002474016020 0ustar pjcjpjcj# Copyright 2005-2013, Paul Johnson (paul@pjcj.net) require 5.006; use strict; use warnings; our $AUTOLOAD; our $VERSION = "1.15"; package Gedcom::WebServices; use Gedcom 1.19; use Apache::Constants qw( OK DECLINED ); use Apache::Request; use Apache::URI; sub _new { my $class = shift; my $r = shift; my $self = { r => $r ? Apache::Request->instance($r) : $r, @_ }; bless $self, $class } sub _set_handlers { my ($handlers) = @_; my $handler_text; for my $h (@{$handlers}) { # print STDERR "creating $type handler for $h\n"; $handler_text .= _create_handler($h); } # print STDERR "handler_text is [$handler_text]\n"; $handler_text } sub _create_handler { my ($h) = @_; my $handler = "___$h"; unless (defined &$handler) { no strict "refs"; *$handler = sub ($$) { my ($class, $r) = @_; my $self; my $vars; eval { my $hn = "__$h"; $self = $class->_new($r, handler => $hn); $self->$hn; }; # die Template::Exception->new("Retemps.perl", $@); # die $@ if $@; $self->_error($@) if $@; exists $self->{_status} ? $self->{_status} : OK }; } my $l = <<"EOE"; \$Location{"/$h"} = { SetHandler => "perl-script", PerlHandler => "Gedcom::WebServices->___$h", }; EOE $l } sub _parse_uri { my $r = shift; my $uri = $r->parsed_uri; my $path = $uri->path; # print STDERR "parse path $path\n"; if ($path =~ s!^/ws/(plain|json|xml)/!!) { $r->notes(PATH => $path); # print STDERR "parse new path [$1]\n"; $r->uri("/$1"); } DECLINED } sub _error { my $self = shift; my ($msg) = @_; print $msg; } sub _process { my $self = shift; my ($type) = @_; my $path = $self->{r}->notes("path"); # print STDERR "$type [$path]\n"; my @params = split "/", $path; my $file = shift @params or die "No GEDCOM file specified\n"; my $gedcom_file = "$Gedcom::ROOT/$file.ged"; # print STDERR "gedcom_file $gedcom_file\n"; my $ged = $self->{ged} = Gedcom->new(gedcom_file => $gedcom_file, read_only => 1); die "Can't open gedcom file [$gedcom_file]\n" unless $ged; # print STDERR "params @params\n"; my @ret; if (@params) { my $xref = shift @params; my $rec = $ged->resolve_xref($xref) || $ged->resolve_xref(uc $xref) || die "Can't get record [$xref]\n"; if (@params) { my ($action, @parms) = @params; die "Invalid action [$action]\n" unless $rec->can($action); if ($Gedcom::Funcs{lc $action} && @parms) { # print STDERR "Calling get_value(@params)\n"; @ret = $rec->get_value(@params); } else { # print STDERR "Calling $action(@params)\n"; @ret = $rec->$action(@parms); } } else { if ($type eq "plain") { $rec->write(\*STDOUT); } elsif ($type eq "xml") { my $r = $rec->hash; $rec->write_xml(\*STDOUT); } elsif ($type eq "json") { my $r = $rec->hash; # use DDS; print STDERR Dump $r; print JSON->new->objToJson({ rec => $r }); } else { die "unrecognised type: $type"; } } } elsif (my $search = $self->{r}->param("search")) { @ret = $ged->get_individual($search); } else { die "No xref or parameters specified\n"; } # print @ret . "\n"; # use Data::Dumper; print Dumper \@ret; for (@ret) { if (ref) { if (defined $_->{xref}) { print "/ws/$type/$file/", $_->xref, "\n"; } else { if ($type eq "plain") { $_->write(\*STDOUT, scalar @params); } elsif ($type eq "xml") { $_->write_xml(\*STDOUT); } elsif ($type eq "json") { my $r = $_->hash; # use DDS; print STDERR Dump $r; print JSON->new->objToJson($r); } else { die "unrecognised type: $type"; } } } else { my $result = @params ? $params[-1] : "result"; if ($type eq "plain") { print "$_\n"; } elsif ($type eq "xml") { $result = uc $result; print "<$result>$_\n"; } elsif ($type eq "json") { print JSON->new->objToJson({ $result => $_ }); } else { die "unrecognised type: $type"; } } } print "\n" unless @ret; } sub __plain { my $self = shift; $self->_process("plain"); } sub __xml { my $self = shift; $self->_process("xml"); } sub __json { my $self = shift; require JSON; $self->_process("json"); } 1; __END__ =head1 NAME Gedcom::WebServices - Basic web service routines for Gedcom.pm Version 1.19 - 18th August 2013 =head1 SYNOPSIS wget -qO - http://www.example.com/ws/plain/my_family/i9/name =head1 DESCRIPTION This module provides web service access to a GEDCOM file in conjunction with mod_perl. Using it, A request for information can be made in the form of a URL specifying the GEDCOM file to be used, which information is required and the format in which the information is to be delivered. This information is then returned in the specified format. There are currently three supported formats: =over =item * plain - no markup =item * XML =item * JSON =back =head2 URLs The format of the URLs used to access the web services are: $BASEURL/$FORMAT/$GEDCOM/$XREF/requested/information $BASEURL/$FORMAT/$GEDCOM?search=search_criteria =over =item BASEURL The base URL to access the web services. =item FORMAT The format in which to return the results. =item GEDCOM The name of the GEDCOM file to use (the extension .ged is assumed). =item XREF The xref of the record about which information is required. XREFs can be obtained initially from a search, and subsequently from certain queries. =item requested/information The information requested. This is in the same format as that taken by the get_value method. =item search_criteria An individual to search for. This is in the same format as that taken by the get_individual method. =back =head1 EXAMPLES $ wget -qO - 'http://pjcj.sytes.net:8585/ws/plain/royal92?search=elizabeth_ii' /ws/plain/royal92/I52 $ wget -qO - http://pjcj.sytes.net:8585/ws/plain/royal92/I52 0 @I52@ INDI 1 NAME Elizabeth_II Alexandra Mary/Windsor/ 1 TITL Queen of England 1 SEX F 1 BIRT 2 DATE 21 APR 1926 2 PLAC 17 Bruton St.,London,W1,England 1 FAMS @F14@ 1 FAMC @F12@ $ wget -qO - http://pjcj.sytes.net:8585/ws/plain/royal92/I52/name Elizabeth_II Alexandra Mary /Windsor/ $ wget -qO - http://pjcj.sytes.net:8585/ws/plain/royal92/I52/birth/date 21 APR 1926 $ wget -qO - http://pjcj.sytes.net:8585/ws/plain/royal92/I52/children /ws/plain/royal92/I58 /ws/plain/royal92/I59 /ws/plain/royal92/I60 /ws/plain/royal92/I61 $ wget -qO - http://pjcj.sytes.net:8585/ws/json/royal92/I52/name {"name":"Elizabeth_II Alexandra Mary /Windsor/"} $ wget -qO - http://pjcj.sytes.net:8585/ws/xml/royal92/I52/name Elizabeth_II Alexandra Mary /Windsor/ $ wget -qO - http://pjcj.sytes.net:8585/ws/xml/royal92/I52 Elizabeth_II Alexandra Mary/Windsor/ Queen of England F 21 APR 1926 17 Bruton St.,London,W1,England =head1 CONFIGURATION Add a section similar to the following to your mod_perl config: PerlWarn On PerlTaintCheck On PerlPassEnv GEDCOM_TEST $Gedcom::TEST = 1; use Apache::Status; $ENV{PATH} = "/bin:/usr/bin"; delete @ENV{"IFS", "CDPATH", "ENV", "BASH_ENV"}; $Gedcom::DATA = $Gedcom::ROOT; # location of data stored on server use lib "$Gedcom::ROOT/blib/lib"; use Gedcom::WebServices; my $handlers = [ qw ( plain xml json ) ]; eval Gedcom::WebServices::_set_handlers($handlers); # use Apache::PerlSections; print STDERR Apache::PerlSections->dump; PerlTransHandler Gedcom::WebServices::_parse_uri =head1 BUGS Very probably. See the BUGS file. And the TODO file. =head1 VERSION Version 1.19 - 18th August 2013 =head1 LICENCE Copyright 2005-2013, Paul Johnson (paul@pjcj.net) 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 =cut Gedcom-1.19/lib/Gedcom/Grammar.pm0000644000175000017500000001160112204002473015161 0ustar pjcjpjcj# Copyright 1998-2013, Paul Johnson (paul@pjcj.net) # 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::Grammar; use Data::Dumper; use Gedcom::Item 1.19; use vars qw($VERSION @ISA); $VERSION = "1.19"; @ISA = qw( Gedcom::Item ); sub structure { my $self = shift; my ($struct) = @_; unless (exists $self->{top}{structures}) { $self->{top}{structures} = { map { $_->{structure} ? ($_->{structure} => $_) : () } @{$self->{top}{items}} }; } # print Dumper $self->{top}{structures}; $self->{top}{structures}{$struct} } sub item { my $self = shift; my ($tag) = @_; return unless defined $tag; my $valid_items = $self->valid_items; # use Data::Dumper; print "[$tag] -- ", Dumper($self), Dumper $valid_items; return unless exists $valid_items->{$tag}; map { $_->{grammar} } @{$valid_items->{$tag}} } sub min { my $self = shift; exists $self->{min} ? $self->{min} : 1 } sub max { my $self = shift; exists $self->{max} ? $self->{max} eq "M" ? 0 : $self->{max} : 1 } sub items { my $self = shift; keys %{$self->valid_items} } sub _valid_items { my $self = shift; my %valid_items; for my $item (@{$self->{items}}) { my $min = $item->min; my $max = $item->max; if ($item->{tag}) { push @{$valid_items{$item->{tag}}}, { grammar => $item, min => $min, max => $max }; } else { die "What's a " . Data::Dumper->new([$item], ["grammar"]) unless my ($value) = $item->{value} =~ /<<(.*)>>/; die "Can't find $value in gedcom structures" unless my $structure = $self->structure($value); $item->{structure} = $structure; while (my($tag, $g) = each %{$structure->valid_items}) { 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_grammars) = each %valid_items) { for my $sub_grammar (@$sub_grammars) { $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 } sub valid_items { my $self = shift; $self->{_valid_items} ||= $self->_valid_items } 1; __END__ =head1 NAME Gedcom::Grammar - a module to manipulate Gedcom grammars Version 1.19 - 18th August 2013 =head1 SYNOPSIS use Gedcom::Grammar; my $st = $grammar->structure("GEDCOM"); my @sgr = $grammar->item("DATE"); my @items = $grammar->valid_items; my $min = $grammar->min; my $max = $grammar->max; my @items = $grammar->items; =head1 DESCRIPTION A selection of subroutines to handle the grammar of a gedcom file. Derived from Gedcom::Item. =head1 HASH MEMBERS Some of the more important hash members are: =head2 $grammar->{top} The top of the grammar tree. =head2 $grammar->{top}{structures} A reference to a hash mapping the names of all structures to the grammar objects. =head1 METHODS =head2 structures my $st = $grammar->structure("GEDCOM"); Return the grammar item of the specified structure, if it exists, or undef. =head2 item my @sgr = $grammar->item("DATE"); Return a list of the possible grammar items of the specified sub-item, if it exists. =head2 min my $min = $grammar->min; Return the minimum permissible number of $grammar items =head2 max my $max = $grammar->max; Return the maximum permissible number of $grammar items =head2 items my @items = $grammar->items; Return a list of tags of the grammar's sub-items =head2 valid_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 an array of hashes with three members: grammar => the sub-item grammar min => the minimum permissible number of these sub-items max => the maximum permissible number of these sub-items =cut Gedcom-1.19/lib/Gedcom/Family.pm0000644000175000017500000000656612204002473015032 0ustar pjcjpjcj# Copyright 1998-2013, Paul Johnson (paul@pjcj.net) # 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::Family; use Gedcom::Record 1.19; use vars qw($VERSION @ISA); $VERSION = "1.19"; @ISA = qw( Gedcom::Record ); sub husband { my $self = shift; my @a = $self->resolve($self->tag_value("HUSB")); wantarray ? @a : $a[0] } sub wife { my $self = shift; my @a = $self->resolve($self->tag_value("WIFE")); wantarray ? @a : $a[0] } sub parents { my $self = shift; ($self->husband, $self->wife) } sub number_of_children { my ($self) = @_; my $nchi = $self->tag_value("NCHI"); defined $nchi ? $nchi : ($#{[$self->children]} + 1) } sub children { my $self = shift; my @a = $self->resolve($self->tag_value("CHIL")); wantarray ? @a : $a[0] } sub boys { my $self = shift; my @a = grep { $_->tag_value("SEX") !~ /^F/i } $self->children; wantarray ? @a : $a[0] } sub girls { my $self = shift; my @a = grep { $_->tag_value("SEX") !~ /^M/i } $self->children; 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; $self->_items if shift; $self->SUPER::print; $_->print for @{$self->{items}}; } 1; __END__ =head1 NAME Gedcom::Family - a module to manipulate Gedcom families Version 1.19 - 18th August 2013 =head1 SYNOPSIS use Gedcom::Family; my @rel = $f->husband; my @rel = $f->wife; my @rel = $f->parents; my $nch = $f->number_of_children; my @rel = $f->children; my @rel = $f->boys; my @rel = $f->girls; $f->add_husband($i); $f->add_wife($i); $f->add_child($i); =head1 DESCRIPTION A selection of subroutines to handle families in a gedcom file. Derived from Gedcom::Record. =head1 HASH MEMBERS None. =head1 METHODS None yet. =head2 Individual functions my @rel = $f->husband; my @rel = $f->wife; my @rel = $f->parents; my @rel = $f->children; my @rel = $f->boys; my @rel = $f->girls; Return a list of individuals from family $f. Each function, even those with a singular name such as husband(), returns a list of individuals holding that relation in $f. =head2 number_of_children my $nch = $f->number_of_children; 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 preferred to the low level addition functions which do not do this. =cut Gedcom-1.19/lib/Gedcom/Item.pm0000644000175000017500000006042612204002474014503 0ustar pjcjpjcj# Copyright 1998-2013, Paul Johnson (paul@pjcj.net) # 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::Item; use Symbol; use vars qw($VERSION); $VERSION = "1.19"; sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = { level => -3, file => "*", line => 0, items => [], @_ }; bless $self, $class; $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 pointer min max gedcom)) { $item->{$key} = $self->{$key} if exists $self->{$key} } $item->{items} = [ map { $_->copy } @{$self->_items} ]; $item } sub hash { my $self = shift; my $item = {}; for my $key (qw(level xref tag value pointer min max)) { $item->{$key} = $self->{$key} if exists $self->{$key} } $item->{items} = [ map { $_->hash } @{$self->_items} ]; $item } sub read { my $self = shift; # $self->{fh} = FileHandle->new($self->{file}) my $fh = $self->{fh} = gensym; open $fh, $self->{file} or die "Can't open file $self->{file}: $!\n"; # try to determine encoding my $encoding = "unknown"; my $bom = 0; my $line1 = <$fh>; if ($line1 =~ /^\xEF\xBB\xBF/) { $encoding = "utf-8"; $bom = 1; } else { while (<$fh>) { if (my ($char) = /\s*1\s+CHAR\s+(.*?)\s*$/i) { $encoding = $char =~ /utf\W*8/i ? "utf-8" : $char; last; } } } # print "encoding is [$encoding]\n"; $self->{gedcom}->set_encoding($encoding) if $self->{gedcom}; if ($encoding eq "utf-8" && $] >= 5.8) { binmode $fh, ":encoding(UTF-8)"; binmode STDOUT, ":encoding(UTF-8)"; binmode STDERR, ":encoding(UTF-8)"; } else { binmode $fh; } # find out how big the file is seek($fh, 0, 2); my $size = tell $fh; seek($fh, $bom ? 3 : 0, 0); # skip BOM # initial callback my $callback = $self->{callback};; my $title = "Reading"; my $txt1 = "Reading $self->{file}"; my $count = 0; return undef if $callback && !$callback->($title, $txt1, "Record $count", tell $fh, $size); $self->level($self->{grammar} ? -1 : -2); my $if = "$self->{file}.index"; my ($gf, $gc); if ($self->{gedcom}{read_only} && defined ($gf = -M $self->{file}) && defined ($gc = -M $if) && $gc < $gf) { if (! open I, $if) { die "Can't open $if: $!"; } else { my $g = $self->{gedcom}{grammar}->structure("GEDCOM"); while () { my @vals = split /\|/; my $record = Gedcom::Record->new(gedcom => $self->{gedcom}, tag => $vals[0], line => $vals[3], cpos => $vals[4], grammar => $g->item($vals[0]), fh => $fh, level => 0); $record->{xref} = $vals[1] if length $vals[1]; $record->{value} = $vals[2] if length $vals[2]; my $class = $self->{gedcom}{types}{$vals[0]}; bless $record, "Gedcom::$class" if $class; push @{$self->{items}}, $record; } close I or warn "Can't close $if"; } } unless (@{$self->{items}}) { # $#{$self->{items}} = 20000; # $#{$self->{items}} = -1; # If we have a grammar, then we are reading a gedcom file and must use # the grammar to verify what is being read. # If we do not have a grammar, then that is what we are reading. while (my $item = $self->next_item($self)) { if ($self->{grammar}) { my $tag = $item->{tag}; my @g = $self->{grammar}->item($tag); # print "<$tag> => <@g>\n"; if (@g) { $self->parse($item, $g[0]); push @{$self->{items}}, $item; $count++; } else { $tag = "" unless defined $tag && length $tag; warn "$self->{file}:$item->{line}: $tag is not a top level tag\n"; } } else { # just add the grammar item push @{$self->{items}}, $item; $count++; } return undef if ref $item && $callback && !$callback->($title, $txt1, "Record $count line " . $item->{line}, tell $fh, $size); } } # unless ($self->{gedcom}{read_only}) # { # $self->{fh}->close or die "Can't close file $self->{file}: $!"; # delete $self->{fh}; # } if ($self->{gedcom}{read_only} && defined $gf && (! defined $gc || $gc > $gf)) { if (! open I, ">$if") { warn "Can't open $if"; } else { for my $item (@{$self->{items}}) { print I join("|", map { $item->{$_} || "" } qw(tag xref value line cpos)); print I "\n"; } close I or warn "Can't close $if"; } } $self; } sub add_items { my $self = shift; my ($item, $parse) = @_; # print "adding items to: "; $item->print; if (!$parse && $item->{level} >= 0 && $self->{gedcom}{read_only} && $self->{gedcom}{grammar}) { # print "ignoring items\n"; $self->skip_items($item); } else { if ($parse && $self->{gedcom}{read_only} && $self->{gedcom}{grammar}) { # print "reading items\n"; if (defined $item->{cpos}) { seek($self->{fh}, $item->{cpos}, 0); $. = $item->{line}; } } $item->{items} = []; while (my $next = $self->next_item($item)) { unless (ref $next) { # The grammar requires a single selection from its items $item->{selection} = 1; next; } my $level = $item->{level}; my $next_level = $next->{level}; if (!defined $next_level || $next_level <= $level) { $self->{stored_item} = $next; # print "stored ***********************************\n"; return; } else { warn "$self->{file}:$item->{line}: " . "Can't add level $next_level to $level\n" if $next_level > $level + 1; push @{$item->{items}}, $next; } } $item->{_items} = 1 unless $item->{gedcom}{read_only}; } } sub skip_items { my $self = shift; my ($item) = @_; my $level = $item->{level}; 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>) { chomp $l; # print "parsing <$l>\n"; if (my ($lev) = $l =~ /^\s*(\d+)/) { if ($lev <= $level) { # print "pushing <$l>\n"; seek($self->{fh}, $cpos, 0); $.--; last; } } $cpos = tell $self->{fh}; } } sub next_item { my $self = shift; my ($item) = @_; my $bpos = tell $self->{fh}; my $bline = $.; # print "At $bpos:$bline\n"; my $rec; my $fh = $self->{fh}; if ($rec = $self->{stored_item}) { $self->{stored_item} = undef; } elsif ((!$rec || !$rec->{level}) && (my $line = $self->next_text_line)) { # TODO - tidy this up my $line_number = $.; # print "line $line_number is <$line>"; if (my ($structure) = $line =~ /^\s*(\w+): =\s*$/) { $rec = $self->new(level => -1, structure => $structure, line => $line_number); # print "found structure $structure\n"; } elsif (my ($level, $xref, $tag, $value, $min, $max) = $line =~ /^\s* # optional whitespace at start ((?:\+?\d+)|n) # start level \s* # optional whitespace (?: # xref (@?@) # text in @?@ \s+ # whitespace )? # optional (?: # tag (?!<<) # don't match a type ([\w\s\[\]\|<>]+?) # non greedy \s+ # whitespace )? # optional (?: # value ( # (?: # one of @??@? # text element - non greedy | # or \[\s* # start list (?: # @?<.*>@? # text element \s*\|?\s* # optionally delimited )+ # one or more \] # end list ) # ) # \s+ # whitespace )?? # optional - non greedy (?: # value \{ # open brace (\d+) # min : # : (\d+|M) # max \*? # optional * [\}\]] # close brace or bracket )? # optional \*? # optional * \s*$/x) # optional whitespace at end # $line =~ /^\s* # optional whitespace at start # (\d+) # start level # \s* # optional whitespace # (?: # xref # (@.*@) # text in @@ # \s+ # whitespace # )? # optional # (\w+) # tag # \s* # whitespace # (?: # value # (@?.*?@?) # text element - non greedy # \s+ # whitespace # )?? # optional - non greedy # \s*$/x) # optional whitespace at end { # print "found $level below $item->{level}\n"; if ($level eq "n" || $level > $item->{level}) { unless ($rec) { $rec = $self->new(line => $line_number); $rec->{gedcom} = $self->{gedcom} if $self->{gedcom}{grammar}; } $rec->{level} = ($level eq "n" ? 0 : $level) if defined $level; $rec->{xref} = $xref =~ /^\@(.+)\@$/ ? $1 : $xref if defined $xref; $rec->{tag} = $tag if defined $tag; $rec->{value} = ($rec->{pointer} = $value =~ /^\@(.+)\@$/) ? $1 : $value if defined $value; $rec->{min} = $min if defined $min; $rec->{max} = $max if defined $max; } else { # print " -- pushing back\n"; seek($fh, $bpos, 0); $. = $bline; } } elsif ($line =~ /^\s*[\[\|\]]\s*(?:\/\*.*\*\/\s*)?$/) { # The grammar requires a single selection from its items. return "selection"; } else { chomp $line; my $file = $self->{file}; die "\n$file:$line_number: Can't parse line: $line\n"; } } # print "\ncomparing "; $item->print; # print "with "; $rec->print if $rec; $self->add_items($rec) if $rec && defined $rec->{level} && ($rec->{level} > $item->{level}); $rec; } sub next_line { my $self = shift; my $fh = $self->{fh}; my $line = <$fh>; $line; } sub next_text_line { my $self = shift; my $line = ""; my $fh = $self->{fh}; $line = <$fh> until !defined $line || $line =~ /\S/; $line; } sub write { my $self = shift; my ($fh, $level, $flush) = @_; $level ||= 0; my @p; push(@p, $level . " " x $level) unless $flush || $level < 0; 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 defined $self->{value} && length $self->{value}; $fh->print("@p"); $fh->print("\n") unless $level < 0; for my $c (0 .. @{$self->_items} - 1) { $self->{items}[$c]->write($fh, $level + 1, $flush); $fh->print("\n") if $level < 0 && $c < @{$self->{items}} - 1; } } sub write_xml { my $self = shift; my ($fh, $level) = @_; return if $self->{tag} && $self->{tag} =~ /^(CON[CT]|TRLR)$/; my $spaced = 0; my $events = 0; $level = 0 unless $level; my $indent = " " x $level; my $tag = $level >= 0 && $self->{tag}; my $value = $self->{value} ? ref $self->{value} ? $self->{value}{xref} : $self->full_value : undef; $value =~ s/\s+$// if defined $value; my $sub_items = @{$self->_items}; my $p = ""; if ($tag) { $tag = $events && defined $self->{gedcom}{types}{$self->{tag}} && $self->{gedcom}{types}{$self->{tag}} eq "Event" ? "EVEN" : $self->{tag}; $tag = "GED" if $tag eq "GEDCOM"; $p .= $indent; $p .= "<$tag"; if ($tag eq "EVEN") { $p .= qq( EV="$self->{tag}"); } elsif ($tag =~ /^(FAM[SC]|HUSB|WIFE|CHIL|SUBM|NOTE)$/ && defined $value && $self->resolve_xref($self->{value})) { $p .= qq( REF="$value"); $value = undef; $tag = undef unless $sub_items; } elsif ($self->{xref}) { $p .= qq( ID="$self->{xref}"); } $p .= "/" unless defined $value || $tag; $p .= ">"; $p .= "\n" if $sub_items || (!$spaced && (!(defined $value || $tag) || $tag eq "EVEN" || $self->{xref})); } if (defined $value) { $p .= "$indent " if $spaced || $sub_items; $p .= $value; $p .= "\n" if $spaced || $sub_items; } $fh->print($p); for my $c (0 .. $sub_items - 1) { $self->{items}[$c]->write_xml($fh, $level + 1); } if ($tag) { $fh->print($indent) if $spaced || $sub_items; $fh->print("\n"); } } sub print { my $self = shift; for my $v (qw( level xref tag value min max )) { print($v, ": ", $self->{$v}, " ") if defined $self->{$v}; } print "\n"; } sub get_item { my $self = shift; my ($tag, $count) = @_; if (wantarray && !$count) { return grep { $_->{tag} eq $tag } @{$self->_items}; } else { $count = 1 unless $count; for my $c (@{$self->_items}) { return $c if $c->{tag} eq $tag && !--$count; } } undef } sub get_child { # NOTE - This function is deprecated - use get_item instead my $self = shift; my ($t) = @_; my ($tag, $count) = $t =~ /^_?(\w+?)(\d*)$/; $self->get_item($tag, $count); } sub get_children { # NOTE - This function is deprecated - use get_item instead my $self = shift; $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}) { 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 pointer min max gedcom file line)) { no strict "refs"; *$func = sub { my $self = shift; $self->{$func} = shift if @_; $self->{$func} } } sub full_value { my $self = shift; my $value = $self->{value}; $value =~ s/[\r\n]+$// if defined $value; for my $item (@{$self->_items}) { my $v = defined $item->{value} ? $item->{value} : ""; $v =~ s/[\r\n]+$//; $value .= "\n$v" if $item->{tag} eq "CONT"; $value .= $v if $item->{tag} eq "CONC"; } $value } sub _items { my $self = shift; $self->{gedcom}{record}->add_items($self, 1) if !defined $self->{_items} && $self->{level} >= 0; $self->{_items} = 1; $self->{items} } sub items { my $self = shift; @{$self->_items} } sub delete_items { my $self = shift; delete $self->{_items}; delete $self->{items}; } 1; __END__ =head1 NAME Gedcom::Item - a base class for Gedcom::Grammar and Gedcom::Record Version 1.19 - 18th August 2013 =head1 SYNOPSIS use Gedcom::Record; $item->{grammar} = Gedcom::Grammar->new(file => $item->{grammar_file}, callback => $item->{callback}); my $c = $item->copy; $item->read if $item->{file}; $item->add_items($rec); while (my $next = $item->next_item($item)) my $line = $item->next_line; my $line = $item->next_text_line; $item->write($fh, $level, $flush); $item->write_xml($fh, $level); $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; my $v = $item->file; my $v = $item->line; my $v = $item->full_value; my $sub_items = $item->_items; my @sub_items = $item->items; $item->delete_items; =head1 DESCRIPTION A selection of subroutines to handle items in a gedcom file. =head1 HASH MEMBERS Some of the more important hash members are: =head2 $item->{level} The level of the item. =head2 $item->{xref} The cross reference, either hard or soft. =head2 $item->{tag} The name of the tag. =head2 $item->{value} 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. =head2 $item->{max} The maximum number of items allowed. =head2 $item->{gedcom} The top level gedcom object. =head2 $item->{file} The file from which this object was read, if any. =head2 $item->{line} The line number from which this object was read, if any. =head2 $item->{items} Array of all sub-items of this item. It should not be necessary to access these hash members directly. =head1 METHODS =head2 new $item->{grammar} = Gedcom::Grammar->new(file => $item->{grammar_file}, callback => $item->{callback}); Create a new object. If file is supplied, it is the name of a file to read. If callback is supplied, it is a subroutine reference which is called at various times while the file is being read. The subroutine takes five parameters: $title: A title $txt1: One text message $txt2: A secondary text message $current: A count of how far through the file we are $total: The extent of the file The subroutine should return true iff the file should continue to be read. =head2 copy my $c = $item->copy; Make a copy of the object. The sub-items are copied too. =head2 read $item->read if $item->{file}; Read a file into the object. Called by the constructor. =head2 add_items $item->add_items($rec); Read in the sub-items of a item. =head2 next_item while (my $next = $item->next_item($item)) Read the next item from a file. Return the item or false if it cannot be read. =head2 next_line my $line = $item->next_line; Read the next line from the file, and return it or false. =head2 next_text_line my $line = $item->next_text_line; Read the next line of text from the file, and return it or false. =head2 write $item->write($fh, $level, $flush); Write the item to a FileHandle. The subroutine takes three parameters: $fh: The FileHandle to which to write $level: The level of the item $flush: Whether or not to indent the gedcom output according to the level =head2 write_xml $item->write_xml($fh, $level); Write the item to a FileHandle as XML. The subroutine takes two parameters: $fh: The FileHandle to which to write $level: The level of the item Note that this function is experimental. Please read the warnings for Gedcom::write_xml(). =head2 print $item->print; Print the item. Used for debugging. (What? There are bugs?) =head2 get_item my $item = $item->get_item("CHIL", 2); my @items = $item->get_items("CHIL"); Get specific sub-items from the item. The arguments are the name of the tag, and optionally the count. In scalar context, returns the sub-item, or undef if it doesn't exist. In array context, returns all sub-items matching the specified tag. =head2 get_child NOTE - This function is deprecated - use get_item instead my $child = get_child("CHIL2"); Get a specific child item from the item. The argument contains the name of the tag, and optionally the count. The regular expression to generate the tag and the count is: my ($tag, $count) = $t =~ /^_?(\w+?)(\d*)$/ Returns the child item, or undef if it doesn't exist =head2 get_children 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; my $v = $item->file; my $v = $item->line; Return the eponymous hash element. If a value if passed into the function, the element is first assigned that value. =head2 full_value my $v = $item->full_value; Return the value of the item including all CONT and CONC lines. This is probably what you want most of the time, and is the function called by default from other functions that return values. If, for some reason, you want to process CONT and CONC items yourself, you will need to use the value() function and probably the items() function. =head2 _items my $sub_items = $item->_items; Return a reference to a list of all the sub-items, reading them from the Gedcom file if they have not already been read. It should not be necessary to use this function. See items(). =head2 items my @sub_items = $item->items; Return a list of all the sub-items, reading them from the Gedcom file if they have not already been read. In general it should not be necessary to use this function. The sub-items will usually be accessed by name. This function is only necessary if the ordering of the different items is important. This is very rare, but is needed for example, when processing CONT and CONC items. =head2 delete_items $item->delete_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 unless you are using read_only mode and need to reclaim your memory. =cut Gedcom-1.19/lib/Gedcom/Comparison.pm0000644000175000017500000000750412204002473015714 0ustar pjcjpjcj# Copyright 2003-2013, Paul Johnson (paul@pjcj.net) # 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 $Indent); $VERSION = "1.19"; $Indent = 0; BEGIN { eval "use Date::Manip" } # We'll use this if it is available use Gedcom::Item 1.19; my %cache; sub new { my $class = shift; my ($r1, $r2) = @_; $r1 = "" unless defined $r1; $r2 = "" unless defined $r2; my $key ="$r1--$r2"; return $cache{$key} if exists $cache{$key}; my $self = { record1 => $r1, record2 => $r2, }; bless $self, $class; if (!%cache && !$INC{"Date/Manip.pm"}) { warn "Date::Manip.pm may be required to accurately compare dates\n"; } $cache{$key} = $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}); # The values match if neither record has a value, or if both do and # they are the same. if (0) { $self->{value_match} = !(defined $v1 ^ defined $v2); $self->{value_match} &&= $v1 eq $v2 if defined $v1; } else { if ($r1->tag eq "DATE") { my $err; my $d = DateCalc($v1, $v2, \$err, 1); print "**** [$v1] [$v2] $d\n"; my @d = split ":", $d; $self->{value_match} = grep (!($_ + 0), @d) / @d; } else { $self->{value_match} = !(defined $v1 ^ defined $v2); $self->{value_match} &&= $v1 eq $v2 if defined $v1; } } my @r1 = $r1 && UNIVERSAL::isa($r1, "Gedcom::Item") ? $r1->items : (); my @r2 = $r2 && UNIVERSAL::isa($r2, "Gedcom::Item") ? $r2->items : (); TAG1: for my $i1 (@r1) { my $tag = $i1->tag; my @match = (-1, -1); for my $i2 (0 .. $#r2) { next unless $r2[$i2]->tag eq $tag; my $comp = Gedcom::Comparison->new($i1, $r2[$i2]); # TODO memoise my $m = $comp->match; @match = ($i2, $m, $comp) if $m > $match[1]; } if ($match[2]) { push @{$self->{$match[2]->identical ? "identical" : "conflict"}}, $match[2]; splice @r2, $match[0], 1; next } push @{$self->{only1}}, $i1; } $self->{only2} = \@r2; $self } sub identical { my $self = shift; $self->match == 100 } sub match { my $self = shift; $self->{match} = 100 * ($self->{value_match} + @{$self->{identical}}) / (1 + @{$self->{identical}} + @{$self->{conflict}} + @{$self->{only1}} + @{$self->{only2}}) unless exists $self->{match}; $self->{match} } sub print { my $self = shift; local $Indent = $Indent + 1; my $i = " " x ($Indent - 1); print $self->identical ? $i : "${i}not "; print "identical\n"; printf "${i}match: %5.2f%%\n", $self->match; printf "${i}value match: %d\n", $self->{value_match}; printf "${i}identical: %d\n", scalar @{$self->{identical}}; printf "${i}conflict: %d\n", scalar @{$self->{conflict}}; printf "${i}only1: %d\n", scalar @{$self->{only1}}; printf "${i}only2: %d\n", scalar @{$self->{only2}}; print "${i}record 1:\n"; $self->{record1}->print; print "${i}record 2:\n"; $self->{record2}->print; print "${i}conflicts:\n"; my $c; print($i, ++$c, ":\n"), $_->print for @{$self->{conflict}}; } 1; __END__ =head1 NAME Gedcom::Comparison - a module to compare Gedcom records Version 1.19 - 18th August 2013 =head1 SYNOPSIS use Gedcom::Comparison; =head1 DESCRIPTION =head1 METHODS =cut Gedcom-1.19/lib/Gedcom/Grammar_5_5.pm0000644000175000017500000020767212204002474015651 0ustar pjcjpjcj# Copyright 1998-2013, Paul Johnson (paul@pjcj.net) # 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 # This file was automatically generated from gedcom-5.5.grammar # by Paul Johnson,,, # on Sun Aug 18 01:20:28 2013 # Do not edit this file. # Edit gedcom-5.5.grammar if changes need to be made. # Edit parse_grammar or Makefile.PL to increase the legibility of this file. # (Removal of the leading spaces nearly halves the size of the file.) # Version 1.19 - 18th August 2013 use strict; require 5.005; package Gedcom::Grammar_5_5; use vars qw($VERSION $grammar); $VERSION = 1.19; $grammar = bless( { fh => \*Symbol::GEN2, file => 'gedcom-5.5.grammar', gedcom => {}, items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => 0, line => 32, max => 1, min => 1, pointer => '', value => '<
>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => 0, line => 33, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => 0, line => 34, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 35, max => 1, min => 1, tag => 'TRLR' }, 'Gedcom::Grammar' ) ], level => -1, line => 30, structure => 'GEDCOM' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 41, max => 1, min => 0, pointer => '', tag => 'VERS', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 42, max => 1, min => 0, pointer => '', tag => 'NAME', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+3', line => 44, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => '+2', line => 43, max => 1, min => 0, pointer => '', tag => 'CORP', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+3', line => 46, max => 1, min => 0, pointer => '', tag => 'DATE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+3', line => 47, max => 1, min => 0, pointer => '', tag => 'COPR', value => '' }, 'Gedcom::Grammar' ) ], level => '+2', line => 45, max => 1, min => 0, pointer => '', tag => 'DATA', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 40, max => 1, min => 1, pointer => '', tag => 'SOUR', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 48, max => 1, min => 0, pointer => '', tag => 'DEST', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 50, max => 1, min => 0, pointer => '', tag => 'TIME', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 49, max => 1, min => 0, pointer => '', tag => 'DATE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 51, max => 1, min => 1, pointer => 1, tag => 'SUBM', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 52, max => 1, min => 0, pointer => 1, tag => 'SUBN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 53, max => 1, min => 0, pointer => '', tag => 'FILE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 54, max => 1, min => 0, pointer => '', tag => 'COPR', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 56, max => 1, min => 1, pointer => '', tag => 'VERS', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 57, max => 1, min => 1, pointer => '', tag => 'FORM', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 55, max => 1, min => 1, tag => 'GEDC' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 59, max => 1, min => 0, pointer => '', tag => 'VERS', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 58, max => 1, min => 1, pointer => '', tag => 'CHAR', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 60, max => 1, min => 0, pointer => '', tag => 'LANG', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 62, max => 1, min => 1, pointer => '', tag => 'FORM', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 61, max => 1, min => 0, tag => 'PLAC' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 64, max => 'M', min => 0, pointer => '', tag => 'CONT', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+2', line => 65, max => 'M', min => 0, pointer => '', tag => 'CONC', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 63, max => 1, min => 0, pointer => '', tag => 'NOTE', value => '' }, 'Gedcom::Grammar' ) ], level => 0, line => 39, max => 1, min => 1, tag => 'HEAD' }, 'Gedcom::Grammar' ) ], level => -1, line => 37, structure => 'HEADER' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => 0, line => 70, max => 1, min => 1, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 72, max => 1, min => 1, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 74, max => 'M', min => 1, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 76, max => 1, min => 1, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 78, max => 1, min => 1, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 80, max => 1, min => 1, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 82, max => 1, min => 1, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 84, max => 1, min => 1, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => -1, line => 68, selection => 1, structure => 'RECORD' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+3', line => 92, max => 1, min => 1, pointer => '', tag => 'AGE', value => '' }, 'Gedcom::Grammar' ) ], level => '+2', line => 91, max => 1, min => 0, tag => 'HUSB' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+3', line => 94, max => 1, min => 1, pointer => '', tag => 'AGE', value => '' }, 'Gedcom::Grammar' ) ], level => '+2', line => 93, max => 1, min => 0, tag => 'WIFE' }, 'Gedcom::Grammar' ) ], level => '+1', line => 90, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 95, max => 1, min => 0, pointer => 1, tag => 'HUSB', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 96, max => 1, min => 0, pointer => 1, tag => 'WIFE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 97, max => 'M', min => 0, pointer => 1, tag => 'CHIL', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 98, max => 1, min => 0, pointer => '', tag => 'NCHI', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 99, max => 'M', min => 0, pointer => 1, tag => 'SUBM', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 100, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 101, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 102, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 103, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 105, max => 1, min => 0, pointer => '', tag => 'TYPE', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 104, max => 'M', min => 0, pointer => '', tag => 'REFN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 106, max => 1, min => 0, pointer => '', tag => 'RIN', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 107, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 89, max => 1, min => 1, tag => 'FAM', xref => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 87, structure => 'FAM_RECORD' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 113, max => 1, min => 0, pointer => '', tag => 'RESN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 114, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 115, max => 1, min => 0, pointer => '', tag => 'SEX', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 116, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 117, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 118, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 119, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 120, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 121, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 122, max => 'M', min => 0, pointer => 1, tag => 'SUBM', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 123, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 124, max => 'M', min => 0, pointer => 1, tag => 'ALIA', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 125, max => 'M', min => 0, pointer => 1, tag => 'ANCI', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 126, max => 'M', min => 0, pointer => 1, tag => 'DESI', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 127, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 128, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 129, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 130, max => 1, min => 0, pointer => '', tag => 'RFN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 131, max => 1, min => 0, pointer => '', tag => 'AFN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 133, max => 1, min => 0, pointer => '', tag => 'TYPE', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 132, max => 'M', min => 0, pointer => '', tag => 'REFN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 134, max => 1, min => 0, pointer => '', tag => 'RIN', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 135, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 112, max => 1, min => 1, tag => 'INDI', xref => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 110, structure => 'INDIVIDUAL_RECORD' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 141, max => 1, min => 1, pointer => '', tag => 'FORM', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 142, max => 1, min => 0, pointer => '', tag => 'TITL', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 143, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 145, max => 'M', min => 1, pointer => '', tag => 'CONT', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 144, max => 1, min => 1, tag => 'BLOB' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 146, max => 1, min => 0, pointer => 1, tag => 'OBJE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 148, max => 1, min => 0, pointer => '', tag => 'TYPE', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 147, max => 'M', min => 0, pointer => '', tag => 'REFN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 149, max => 1, min => 0, pointer => '', tag => 'RIN', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 150, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 140, max => 1, min => 1, tag => 'OBJE', xref => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 138, structure => 'MULTIMEDIA_RECORD' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 156, max => 'M', min => 0, pointer => '', tag => 'CONC', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 157, max => 'M', min => 0, pointer => '', tag => 'CONT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 158, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 160, max => 1, min => 0, pointer => '', tag => 'TYPE', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 159, max => 'M', min => 0, pointer => '', tag => 'REFN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 161, max => 1, min => 0, pointer => '', tag => 'RIN', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 162, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 155, max => 1, min => 1, pointer => '', tag => 'NOTE', value => '', xref => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 153, structure => 'NOTE_RECORD' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 168, max => 1, min => 0, pointer => '', tag => 'NAME', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 169, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 170, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 172, max => 1, min => 0, pointer => '', tag => 'TYPE', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 171, max => 'M', min => 0, pointer => '', tag => 'REFN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 173, max => 1, min => 0, pointer => '', tag => 'RIN', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 174, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 167, max => 1, min => 1, tag => 'REPO', xref => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 165, structure => 'REPOSITORY_RECORD' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+3', line => 182, max => 1, min => 0, pointer => '', tag => 'DATE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+3', line => 183, max => 1, min => 0, pointer => '', tag => 'PLAC', value => '' }, 'Gedcom::Grammar' ) ], level => '+2', line => 181, max => 'M', min => 0, pointer => '', tag => 'EVEN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 184, max => 1, min => 0, pointer => '', tag => 'AGNC', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 185, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => '+1', line => 180, max => 1, min => 0, tag => 'DATA' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 187, max => 1, min => 0, pointer => '', tag => 'ABBR', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 188, max => 'M', min => 0, pointer => '', tag => 'CONT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 189, max => 'M', min => 0, pointer => '', tag => 'CONC', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 186, max => 1, min => 0, pointer => '', tag => 'AUTH', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 191, max => 'M', min => 0, pointer => '', tag => 'CONT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 192, max => 'M', min => 0, pointer => '', tag => 'CONC', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 190, max => 1, min => 0, pointer => '', tag => 'TITL', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 193, max => 1, min => 0, pointer => '', tag => 'ABBR', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 195, max => 'M', min => 0, pointer => '', tag => 'CONT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 196, max => 'M', min => 0, pointer => '', tag => 'CONC', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 194, max => 1, min => 0, pointer => '', tag => 'PUBL', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 198, max => 'M', min => 0, pointer => '', tag => 'CONT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 199, max => 'M', min => 0, pointer => '', tag => 'CONC', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 197, max => 1, min => 0, pointer => '', tag => 'TEXT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 200, max => 1, min => 0, pointer => '', tag => 'QUAY', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 201, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 202, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 203, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 205, max => 1, min => 0, pointer => '', tag => 'TYPE', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 204, max => 'M', min => 0, pointer => '', tag => 'REFN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 206, max => 1, min => 0, pointer => '', tag => 'RIN', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 207, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 179, max => 1, min => 1, tag => 'SOUR', xref => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 177, structure => 'SOURCE_RECORD' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 213, max => 1, min => 0, pointer => 1, tag => 'SUBM', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 214, max => 1, min => 0, pointer => '', tag => 'FAMF', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 215, max => 1, min => 0, pointer => '', tag => 'TEMP', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 216, max => 1, min => 0, pointer => '', tag => 'ANCE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 217, max => 1, min => 0, pointer => '', tag => 'DESC', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 218, max => 1, min => 0, pointer => '', tag => 'ORDI', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 219, max => 1, min => 0, pointer => '', tag => 'RIN', value => '' }, 'Gedcom::Grammar' ) ], level => 0, line => 212, max => 1, min => 1, tag => 'SUBN', xref => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 210, structure => 'SUBMISSION_RECORD' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 225, max => 1, min => 1, pointer => '', tag => 'NAME', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 226, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 227, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 228, max => 3, min => 0, pointer => '', tag => 'LANG', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 229, max => 1, min => 0, pointer => '', tag => 'RFN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 230, max => 1, min => 0, pointer => '', tag => 'RIN', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 231, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 224, max => 1, min => 1, tag => 'SUBM', xref => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 222, structure => 'SUBMITTER_RECORD' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 237, max => 'M', min => 0, pointer => '', tag => 'CONT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 238, max => 1, min => 0, pointer => '', tag => 'ADR1', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 239, max => 1, min => 0, pointer => '', tag => 'ADR2', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 240, max => 1, min => 0, pointer => '', tag => 'CITY', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 241, max => 1, min => 0, pointer => '', tag => 'STAE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 242, max => 1, min => 0, pointer => '', tag => 'POST', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 243, max => 1, min => 0, pointer => '', tag => 'CTRY', value => '' }, 'Gedcom::Grammar' ) ], level => 0, line => 236, max => 1, min => 0, pointer => '', tag => 'ADDR', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 244, max => 3, min => 0, pointer => '', tag => 'PHON', value => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 234, structure => 'ADDRESS_STRUCTURE' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 250, max => 1, min => 1, pointer => '', tag => 'TYPE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 251, max => 1, min => 1, pointer => '', tag => 'RELA', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 252, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 253, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 249, max => 'M', min => 0, pointer => 1, tag => 'ASSO', value => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 247, structure => 'ASSOCIATION_STRUCTURE' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 260, max => 1, min => 0, pointer => '', tag => 'TIME', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 259, max => 1, min => 1, pointer => '', tag => 'DATE', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 261, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 258, max => 1, min => 1, tag => 'CHAN' }, 'Gedcom::Grammar' ) ], level => -1, line => 256, structure => 'CHANGE_DATE' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 267, max => 'M', min => 0, pointer => '', tag => 'PEDI', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 268, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 266, max => 1, min => 1, pointer => 1, tag => 'FAMC', value => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 264, structure => 'CHILD_TO_FAMILY_LINK' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => 0, line => 273, max => 1, min => 0, pointer => '', tag => 'TYPE', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 274, max => 1, min => 0, pointer => '', tag => 'DATE', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 275, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 276, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 277, max => 1, min => 0, pointer => '', tag => 'AGE', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 278, max => 1, min => 0, pointer => '', tag => 'AGNC', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 279, max => 1, min => 0, pointer => '', tag => 'CAUS', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 280, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 281, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => 0, line => 282, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => -1, line => 271, structure => 'EVENT_DETAIL' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 290, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 289, max => 1, min => 1, tag => 'ANUL' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 293, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 292, max => 1, min => 1, tag => 'CENS' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 296, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 295, max => 1, min => 1, tag => 'DIV' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 299, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 298, max => 1, min => 1, tag => 'DIVF' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 302, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 301, max => 1, min => 1, tag => 'ENGA' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 305, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 304, max => 1, min => 1, tag => 'MARR' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 308, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 307, max => 1, min => 1, tag => 'MARB' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 311, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 310, max => 1, min => 1, tag => 'MARC' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 314, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 313, max => 1, min => 1, tag => 'MARL' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 317, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 316, max => 1, min => 1, tag => 'MARS' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 320, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 319, max => 1, min => 1, tag => 'EVEN' }, 'Gedcom::Grammar' ) ], level => -1, line => 286, selection => 1, structure => 'FAMILY_EVENT_STRUCTURE' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 329, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 328, max => 1, min => 1, pointer => '', tag => 'CAST', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 332, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 331, max => 1, min => 1, pointer => '', tag => 'DSCR', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 335, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 334, max => 1, min => 1, pointer => '', tag => 'EDUC', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 338, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 337, max => 1, min => 1, pointer => '', tag => 'IDNO', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 341, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 340, max => 1, min => 1, pointer => '', tag => 'NATI', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 344, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 343, max => 1, min => 1, pointer => '', tag => 'NCHI', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 347, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 346, max => 1, min => 1, pointer => '', tag => 'NMR', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 350, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 349, max => 1, min => 1, pointer => '', tag => 'OCCU', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 353, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 352, max => 1, min => 1, pointer => '', tag => 'PROP', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 356, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 355, max => 1, min => 1, pointer => '', tag => 'RELI', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 359, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 358, max => 1, min => 1, tag => 'RESI' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 362, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 361, max => 1, min => 0, pointer => '', tag => 'SSN', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 365, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 364, max => 1, min => 1, pointer => '', tag => 'TITL', value => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 325, selection => 1, structure => 'INDIVIDUAL_ATTRIBUTE_STRUCTURE' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 373, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 374, max => 1, min => 0, pointer => 1, selection => 1, tag => 'FAMC', value => '' }, 'Gedcom::Grammar' ) ], level => 0, line => 372, max => 1, min => 1, tag => 'BIRT' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 377, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 378, max => 1, min => 0, pointer => 1, selection => 1, tag => 'FAMC', value => '' }, 'Gedcom::Grammar' ) ], level => 0, line => 376, max => 1, min => 1, tag => 'CHR' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 381, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 380, max => 1, min => 1, tag => 'DEAT' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 384, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 383, max => 1, min => 1, tag => 'BURI' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 387, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 386, max => 1, min => 1, tag => 'CREM' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 390, max => 1, min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+2', line => 392, max => 1, min => 0, pointer => '', selection => 1, tag => 'ADOP', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 391, max => 1, min => 0, pointer => 1, tag => 'FAMC', value => '' }, 'Gedcom::Grammar' ) ], level => 0, line => 389, max => 1, min => 1, tag => 'ADOP' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 395, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 394, max => 1, min => 1, tag => 'BAPM' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 398, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 397, max => 1, min => 1, tag => 'BARM' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 401, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 400, max => 1, min => 1, tag => 'BASM' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 404, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 403, max => 1, min => 1, tag => 'BLES' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 407, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 406, max => 1, min => 1, tag => 'CHRA' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 410, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 409, max => 1, min => 1, tag => 'CONF' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 413, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 412, max => 1, min => 1, tag => 'FCOM' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 416, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 415, max => 1, min => 1, tag => 'ORDN' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 419, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 418, max => 1, min => 1, tag => 'NATU' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 422, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 421, max => 1, min => 1, tag => 'EMIG' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 425, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 424, max => 1, min => 1, tag => 'IMMI' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 428, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 427, max => 1, min => 1, tag => 'CENS' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 431, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 430, max => 1, min => 1, tag => 'PROB' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 434, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 433, max => 1, min => 1, tag => 'WILL' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 437, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 436, max => 1, min => 1, tag => 'GRAD' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 440, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 439, max => 1, min => 1, tag => 'RETI' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 443, max => 1, min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 442, max => 1, min => 1, tag => 'EVEN' }, 'Gedcom::Grammar' ) ], level => -1, line => 369, selection => 1, structure => 'INDIVIDUAL_EVENT_STRUCTURE' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 451, max => 1, min => 0, pointer => '', tag => 'STAT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 452, max => 1, min => 0, pointer => '', tag => 'DATE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 453, max => 1, min => 0, pointer => '', tag => 'TEMP', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 454, max => 1, min => 0, pointer => '', tag => 'PLAC', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 455, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 456, max => 'M', min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 450, max => 1, min => 1, tag => 'BAPL' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 459, max => 1, min => 0, pointer => '', tag => 'STAT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 460, max => 1, min => 0, pointer => '', tag => 'DATE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 461, max => 1, min => 0, pointer => '', tag => 'TEMP', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 462, max => 1, min => 0, pointer => '', tag => 'PLAC', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 463, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 464, max => 'M', min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 458, max => 1, min => 1, tag => 'CONL' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 467, max => 1, min => 0, pointer => '', tag => 'STAT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 468, max => 1, min => 0, pointer => '', tag => 'DATE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 469, max => 1, min => 0, pointer => '', tag => 'TEMP', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 470, max => 1, min => 0, pointer => '', tag => 'PLAC', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 471, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 472, max => 'M', min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 466, max => 1, min => 1, tag => 'ENDL' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 475, max => 1, min => 0, pointer => '', tag => 'STAT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 476, max => 1, min => 0, pointer => '', tag => 'DATE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 477, max => 1, min => 0, pointer => '', tag => 'TEMP', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 478, max => 1, min => 0, pointer => '', tag => 'PLAC', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 479, max => 1, min => 1, pointer => 1, tag => 'FAMC', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 480, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 481, max => 'M', min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 474, max => 1, min => 1, tag => 'SLGC' }, 'Gedcom::Grammar' ) ], level => -1, line => 447, selection => 1, structure => 'LDS_INDIVIDUAL_ORDINANCE' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 488, max => 1, min => 0, pointer => '', tag => 'STAT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 489, max => 1, min => 0, pointer => '', tag => 'DATE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 490, max => 1, min => 0, pointer => '', tag => 'TEMP', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 491, max => 1, min => 0, pointer => '', tag => 'PLAC', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 492, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 493, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 487, max => 1, min => 1, tag => 'SLGS' }, 'Gedcom::Grammar' ) ], level => -1, line => 485, structure => 'LDS_SPOUSE_SEALING' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => 0, line => 499, max => 1, min => 1, pointer => 1, selection => 1, tag => 'OBJE', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 502, max => 1, min => 1, pointer => '', tag => 'FORM', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 503, max => 1, min => 0, pointer => '', tag => 'TITL', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 504, max => 1, min => 1, pointer => '', tag => 'FILE', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 505, max => 'M', min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 501, max => 1, min => 1, tag => 'OBJE' }, 'Gedcom::Grammar' ) ], level => -1, line => 496, selection => 1, structure => 'MULTIMEDIA_LINK' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+1', line => 513, max => 'M', min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 512, max => 1, min => 1, pointer => 1, tag => 'NOTE', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 516, max => 'M', min => 0, pointer => '', tag => 'CONC', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 517, max => 'M', min => 0, pointer => '', tag => 'CONT', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 518, max => 'M', min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 515, max => 1, min => 1, pointer => '', tag => 'NOTE', value => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 509, selection => 1, structure => 'NOTE_STRUCTURE' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 525, max => 1, min => 0, pointer => '', tag => 'NPFX', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 526, max => 1, min => 0, pointer => '', tag => 'GIVN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 527, max => 1, min => 0, pointer => '', tag => 'NICK', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 528, max => 1, min => 0, pointer => '', tag => 'SPFX', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 529, max => 1, min => 0, pointer => '', tag => 'SURN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 530, max => 1, min => 0, pointer => '', tag => 'NSFX', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 531, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 532, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 524, max => 1, min => 1, pointer => '', tag => 'NAME', value => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 522, structure => 'PERSONAL_NAME_STRUCTURE' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 538, max => 1, min => 0, pointer => '', tag => 'FORM', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 539, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 540, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 537, max => 1, min => 1, pointer => '', tag => 'PLAC', value => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 535, structure => 'PLACE_STRUCTURE' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 546, max => 1, min => 0, pointer => '', tag => 'TYPE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 548, max => 1, min => 0, pointer => '', tag => 'ABBR', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 547, max => 1, min => 0, pointer => '', tag => 'TITL', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 549, max => 1, min => 0, pointer => '', tag => 'ABBR', value => '' }, 'Gedcom::Grammar' ) ], level => 0, line => 545, max => 1, min => 1, pointer => '', tag => '_EVENT_DEFN', value => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 543, structure => 'EVENT_DEFINITION' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 556, max => 'M', min => 0, pointer => '', tag => 'CONC', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 557, max => 'M', min => 0, pointer => '', tag => 'CONT', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 555, max => 1, min => 0, pointer => '', tag => 'PAGE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 558, max => 1, min => 0, pointer => '', tag => 'REFN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 560, max => 1, min => 0, pointer => '', tag => 'ROLE', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 559, max => 1, min => 0, pointer => '', tag => 'EVEN', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 562, max => 1, min => 0, pointer => '', tag => 'DATE', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+3', line => 564, max => 'M', min => 0, pointer => '', tag => 'CONC', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+3', line => 565, max => 'M', min => 0, pointer => '', tag => 'CONT', value => '' }, 'Gedcom::Grammar' ) ], level => '+2', line => 563, max => 'M', min => 0, pointer => '', tag => 'TEXT', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 561, max => 1, min => 0, tag => 'DATA' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 566, max => 1, min => 0, pointer => '', tag => 'QUAY', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 567, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 568, max => 'M', min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 554, max => 1, min => 1, pointer => 1, tag => 'SOUR', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 571, max => 'M', min => 0, pointer => '', tag => 'CONC', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 572, max => 'M', min => 0, pointer => '', tag => 'CONT', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 574, max => 'M', min => 0, pointer => '', tag => 'CONC', value => '' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+2', line => 575, max => 'M', min => 0, pointer => '', tag => 'CONT', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 573, max => 'M', min => 0, pointer => '', tag => 'TEXT', value => '' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [], level => '+1', line => 576, max => 'M', min => 0, pointer => '', selection => 1, value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 570, max => 1, min => 1, pointer => '', tag => 'SOUR', value => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 551, selection => 1, structure => 'SOURCE_CITATION' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 583, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ), bless( { file => '*', items => [ bless( { file => '*', items => [], level => '+2', line => 585, max => 1, min => 0, pointer => '', tag => 'MEDI', value => '' }, 'Gedcom::Grammar' ) ], level => '+1', line => 584, max => 'M', min => 0, pointer => '', tag => 'CALN', value => '' }, 'Gedcom::Grammar' ) ], level => 0, line => 582, max => 1, min => 1, pointer => 1, tag => 'REPO', value => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 580, structure => 'SOURCE_REPOSITORY_CITATION' }, 'Gedcom::Grammar' ), bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [ bless( { _items => 1, file => '*', gedcom => {}, items => [], level => '+1', line => 592, max => 'M', min => 0, pointer => '', value => '<>' }, 'Gedcom::Grammar' ) ], level => 0, line => 591, max => 1, min => 1, pointer => 1, tag => 'FAMS', value => '' }, 'Gedcom::Grammar' ) ], level => -1, line => 589, structure => 'SPOUSE_TO_FAMILY_LINK' }, 'Gedcom::Grammar' ) ], level => -2, line => 0, stored_item => undef, version => '5.5' }, 'Gedcom::Grammar' ); Gedcom-1.19/lib/Gedcom/Record.pm0000644000175000017500000005335212204002474015023 0ustar pjcjpjcj# Copyright 1998-2013, Paul Johnson (paul@pjcj.net) # 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::Record; use vars qw($VERSION @ISA $AUTOLOAD); $VERSION = "1.19"; @ISA = qw( Gedcom::Item ); use Carp; BEGIN { eval "use Date::Manip" } # We'll use this if it is available use Gedcom::Item 1.19; use Gedcom::Comparison 1.19; BEGIN { 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 my $func = $AUTOLOAD; # print "autoloading $func\n"; $func =~ s/^.*:://; 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 { $_ && do { $v = $_->full_value; defined $v && length $v ? $v : $_ } } $self->record([$func, $count]); } else { my $r = $self->record([$func, $count]); return $r && do { $v = $r->full_value; defined $v && length $v ? $v : $r } } }; goto &$func } sub record { my $self = shift; my @records = ($self); for my $func (map { ref() ? $_ : split } @_) { my $count = 0; ($func, $count) = @$func if ref $func eq "ARRAY"; 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; } @records = map { $_->tag_record($record, $count) } @records; # fams and famc need to be resolved @records = map { $self->resolve($_->{value}) } @records if $record eq "FAMS" || $record eq "FAMC"; } wantarray ? @records : $records[0] } sub get_value { my $self = shift; if (wantarray) { return map { my $v = $_->full_value; defined $v and length $v ? $v : () } $self->record(@_); } else { my $record = $self->record(@_); return $record && $record->full_value; } } sub tag_value { my $self = shift; if (wantarray) { return map { my $v = $_->full_value; defined $v and length $v ? $v : () } $self->tag_record(@_); } else { my $record = $self->tag_record(@_); return $record && $record->full_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}, tag => $args{tag}, ); if (!defined $self->{grammar}) { warn "$self->{tag} has no grammar\n"; } elsif (my @g = $self->{grammar}->item($args{tag})) { # use DDS; print Dump \@g; my $grammar = $g[0]; for my $g (@g) { # print "testing $args{tag} ", $args{val} // "undef", " against ", # $g->{value} // "undef", "\n"; if ($args{tag} eq "NOTE") { if (( defined $args{xref} && $g->{value} =~ /xref/i) || (!defined $args{xref} && $g->{value} !~ /xref/i)) { # print "note match\n"; $grammar = $g; last; } } else { if (( defined $args{val} && $g->{value}) || (!defined $args{val} && !$g->{value})) { # print "match\n"; $grammar = $g; last; } } } $self->parse($record, $grammar); } else { warn "$args{tag} is not a sub-item of $self->{tag}\n"; } push @{$self->{items}}, $record; $record } sub add { my $self = shift; my ($xref, $val); if (@_ > 1 && ref $_[-1] ne "ARRAY") { $val = pop; if (UNIVERSAL::isa($val, "Gedcom::Record")) { $xref = $val; $val = undef; } } my @funcs = map { ref() ? $_ : split } @_; $funcs[-1] = [$funcs[-1], 0] unless ref $funcs[-1]; push @{$funcs[-1]}, { xref => $xref, val => $val }; my $record = $self->get_and_create(@funcs); if (defined $xref) { $record->{value} = $xref->{xref}; $self->{gedcom}{xrefs}{$xref->{xref}} = $xref; } if (defined $val) { $record->{value} = $val; } $record } 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 = @_; # use DDS; print "get_and_create: " , Dump \@funcs; my $rec = $self; for my $f (0 .. $#funcs) { my ($func, $count, $args) = ($funcs[$f], 1); $args = {} unless defined $args; ($func, $count, $args) = @$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] - $record\n"; my @records = $rec->tag_record($record); if ($count < 0) { $rec = $rec->add_record(tag => $record, %$args); } elsif ($#records < $count) { my $new; $new = $rec->add_record(tag => $record, %$args) for (0 .. @records - $count); $rec = $new; } else { $rec = $records[$count]; } } $rec } sub parse { # print "parsing\n"; my $self = shift; my ($record, $grammar, $test) = @_; $test ||= 0; # print "checking "; $record->print(); # print "against "; $grammar->print(); # print "test is $test\n"; my $t = $record->{tag}; my $g = $grammar->{tag}; die "Can't match $t with $g" if $t && $t ne $g; # internal error $record->{grammar} = $grammar; my $class = $record->{gedcom}{types}{$t}; bless $record, "Gedcom::$class" if $class; my $match = 1; for my $r (@{$record->{items}}) { my $tag = $r->{tag}; my @i; # print "- valid sub-items of $t are @{[keys %{$grammar->valid_items}]}\n"; for my $i ($grammar->item($tag)) { # 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, "|", $r->pointer, "\n"; # next if $i->value && $r->value && ($i->value =~ /^pointer); next if $i->value && ($i->value =~ /^pointer || 0)); # print "pushing\n"; push @i, $i; } # print "valid sub-items of $t are @{[keys %{$grammar->valid_items}]}\n"; # print "<$tag> => <@i>\n"; unless (@i) { # unless $tag eq "CONT" || $tag eq "CONC" || substr($tag, 0, 1) eq "_"; # TODO - should CONT and CONC be allowed anywhere? unless (substr($tag, 0, 1) eq "_") { warn "$self->{file}:$r->{line}: $tag is not a sub-item of $t\n", "Valid sub-items are ", join(", ", sort keys %{$grammar->{_valid_items}}), "\n" unless $test; $match = 0; next; } } # print "$self->{file}:$r->{line}: Ambiguous tag $tag as sub-item of $t, ", # "found ", scalar @i, " matches\n" if @i > 1; my $m = 0; for my $i (@i) { last if $m = $self->parse($r, $i, @i > 1); } if (@i > 1 && !$m) { # TODO - I'm not even sure if this can happen. warn "$self->{file}:$r->{line}: Ambiguous tag $tag as sub-item of $t, ", "found ", scalar @i, " matches, all of which have errors. ", "Reporting errors from last match.\n"; $self->parse($r, $i[-1]); $match = 0; # TODO - count the errors in each match and use the best. } } # print "parsed $match\n"; $match } sub collect_xrefs { my $self = shift; my ($callback) = @_; $self->{gedcom}{xrefs}{$self->{xref}} = $self if defined $self->{xref}; $_->collect_xrefs($callback) for @{$self->{items}}; $self } sub resolve_xref { shift->{gedcom}->resolve_xref(@_); } sub resolve { my $self = shift; 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->{gedcom}->resolve_xref($self->{value})) { $self->{value} = $xref; } $_->resolve_xrefs($callback) for @{$self->_items}; $self } sub unresolve_xrefs { my $self = shift;; my ($callback) = @_; $self->{value} = $self->{value}{xref} if defined $self->{value} and UNIVERSAL::isa $self->{value}, "Gedcom::Record" and exists $self->{value}{xref}; $_->unresolve_xrefs($callback) for @{$self->_items}; $self } my $D = 0; # turn on debug output my $I = -1; # indent for debug output sub validate_syntax { my $self = shift; return 1 unless exists $self->{grammar}; my $ok = 1; $self->{gedcom}{validate_callback}->($self) if defined $self->{gedcom}{validate_callback}; my $grammar = $self->{grammar}; $I++; print " " x $I . "validate_syntax(" . (defined $grammar->{tag} ? $grammar->{tag} : "") . ")\n" if $D; my $file = $self->{gedcom}{record}{file}; my $here = "$file:$self->{line}: $self->{tag}" . (defined $self->{xref} ? " $self->{xref}" : ""); my %counts; for my $record (@{$self->_items}) { print " " x $I . "level $record->{level} on $self->{level}\n" if $D; $ok = 0, warn "$here: Can't add level $record->{level} to $self->{level}\n" if $record->{level} > $self->{level} + 1; $counts{$record->{tag}}++; $ok = 0 unless $record->validate_syntax; } my $valid_items = $grammar->valid_items; for my $tag (sort keys %$valid_items) { for 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 $tag (keys %counts) { for my $c ($self->tag_record($tag)) { $ok = 0, warn "$file:$c->{line}: $tag is not a sub-item of $self->{tag}\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? } } $I--; $ok; } my $Check = { INDI => { FAMS => [ "HUSB", "WIFE" ], FAMC => [ "CHIL" ] }, FAM => { HUSB => [ "FAMS" ], WIFE => [ "FAMS" ], CHIL => [ "FAMC" ], }, }; sub validate_semantics { my $self = shift; return 1 unless $self->{tag} eq "INDI" || $self->{tag} eq "FAM"; # print "validating: "; $self->print; print $self->summary, "\n"; my $ok = 1; my $xrefs = $self->{gedcom}{xrefs}; my $chk = $Check->{$self->{tag}}; for my $f (keys %$chk) { my $found = 1; RECORD: for my $record ($self->tag_value($f)) { $found = 0; $record = $xrefs->{$record} unless ref $record; if ($record) { for my $back (@{$chk->{$f}}) { # print "back $back\n"; for my $i ($record->tag_value($back)) { # print "record is $i\n"; $i = $xrefs->{$i} unless ref $i; if ($i && $i->{xref} eq $self->{xref}) { $found = 1; # print "found...\n"; next RECORD; } } } unless ($found) { # TODO - use the line of the offending record $ok = 0; my $file = $self->{gedcom}{record}{file}; warn "$file:$self->{line}: $f $record->{xref} " . "does not reference $self->{tag} $self->{xref}. Add the line:\n". "$file:" . ($record->{line} + 1) . ": 1 " . join("or ", @{$chk->{$f}}) . " $self->{xref}\n"; } } } } $ok; } sub normalise_dates { my $self = shift; unless ($INC{"Date/Manip.pm"}) { warn "Date::Manip.pm is required to use normalise_dates()"; return; } if( eval { Date::Manip->VERSION( 6 ); } and !eval { Date::Manip->VERSION( 6.13 ); } ) { warn "Unable to normalize dates with this version of Date::Manip. Please upgrade to version 6.13."; return; } my $format = shift || "%A, %E %B %Y"; if (defined $self->{tag} && $self->{tag} =~ /^date$/i) { if (defined $self->{value} && $self->{value}) { # print "date was $self->{value}\n"; my @dates = split / or /, $self->{value}; for my $dt (@dates) { # don't change the date if it is just < 7 digits if ($dt !~ /^\s*(\d+)\s*$/ || length $1 > 6) { my $date = ParseDate($dt); my $d = UnixDate($date, $format); $dt = $d if $d; } } $self->{value} = join " or ", @dates; # print "date is $self->{value}\n"; } } $_->normalise_dates($format) for @{$self->_items}; $self->delete_items if $self->level > 1; } sub renumber { my $self = shift; my ($args, $recurse) = @_; # TODO - add the xref if there is supposed to be one return if exists $self->{recursed} or not defined $self->{xref}; # we can't actually change the xrefs until the end my $x = $self->{tag} eq "SUBM" ? "SUBM" : substr $self->{tag}, 0, 1; $self->{new_xref} = $x . ++$args->{$self->{tag}} unless exists $self->{new_xref}; return unless $recurse and not exists $self->{recursed}; $self->{recursed} = 1; if ($self->{tag} eq "INDI") { my @r = map { $self->$_() } qw(fams famc spouse children parents siblings); $_->renumber($args, 0) for @r; $_->renumber($args, 1) for @r; } } sub child_value { # NOTE - This function is deprecated - use tag_value instead my $self = shift;; $self->tag_value(@_) } sub child_values { # NOTE - This function is deprecated - use tag_value instead my $self = shift;; $self->tag_value(@_) } sub compare { my $self = shift; my ($r) = @_; Gedcom::Comparison->new($self, $r) } sub summary { my $self = shift; my $s = ""; $s .= sprintf("%-5s", $self->{xref}); my $r = $self->tag_record("NAME"); $s .= sprintf(" %-40s", $r ? $r->{value} : ""); $r = $self->tag_record("SEX"); $s .= sprintf(" %1s", $r ? $r->{value} : ""); my $d = ""; if ($r = $self->tag_record("BIRT") and my $date = $r->tag_record("DATE")) { $d = $date->{value}; } $s .= sprintf(" %16s", $d); $s; } 1; __END__ =head1 NAME Gedcom::Record - a module to manipulate Gedcom records Version 1.19 - 18th August 2013 =head1 SYNOPSIS use Gedcom::Record; my $record = tag_record("CHIL", 2); my @records = tag_record("CHIL"); my @recs = $record->record("birth"); my @recs = $record->record("birth", "date"); my $rec = $record->record("birth date"); my $rec = $record->record(["birth", 2], "date"); my @recs = $record->get_record("birth"); my $val = $record->get_value; my @vals = $record->get_value("date"); my @vals = $record->get_value("birth", "date"); my $val = $record->get_value("birth date"); my $val = $record->get_value(["birth", 2], "date"); my $rec = $record->add("birth date", "1 Jan 2000"); my $rec = $record->set("birth date", "2 Jan 2000"); $self->parse($record, $grammar); $record->collect_xrefs($callback); my $xref = $record->resolve_xref($record->{value}); my @famc = $record->resolve $record->get_value("FAMC"); $record->resolve_xrefs($callback); $record->unresolve_xrefs($callback); return 0 unless $record->validate_semantics; $record->normalise_dates($format); $record->renumber($args); print $record->summary, "\n"; $record->delete_record($sub_record); =head1 DESCRIPTION A selection of subroutines to handle records in a gedcom file. Derived from Gedcom::Item. =head1 HASH MEMBERS Some of the more important hash members are: =head2 $record-E{new_xref} Used by renumber(). =head2 $record-E{recursed} Used by renumber(). =head1 METHODS =head2 tag_record my $record = tag_record("CHIL", 2); my @records = tag_record("CHIL"); Get specific sub-records from the record. This function is identical to Gedcom::Item::get_item(). The arguments are the name of the tag, and optionally the count. In scalar context, returns the sub-record, or undef if it doesn't exist. In array context, returns all sub-records matching the specified tag. =head2 record my @recs = $record->record("birth"); my @recs = $record->record("birth", "date"); my $rec = $record->record("birth date"); my $rec = $record->record(["birth", 2], "date"); my @recs = $record->get_record("birth"); Retrieve a record. The get_record() function is identical to the record() function. In scalar context, record() returns the specified record, or undef if there is none. In list context, record() returns all the specified records. Records may be specified by a list of strings. Each string is either a Gedcom tag or a description. Starting from the first string in the list, specified records are retrieved. Then from those records, records specified by the next string in the list are retrieved. This continues until all strings from the list have been used. In list context, all specified records are retrieved. In scalar context, only the first record is retrieved. If a record other than the first is wanted, then instead of passing a string, a reference to an array containing the string and a count may be passed. Instead of specifying a list of strings, it is possible to specify a single space separated string. This can make the interface nicer. =head2 get_value my $val = $record->get_value; my @vals = $record->get_value("date"); my @vals = $record->get_value("birth", "date"); my $val = $record->get_value("birth date"); my $val = $record->get_value(["birth", 2], "date"); Retrieve a record's value. If arguments are specified, record() is first called with those arguments, and the values of those records are returned. =head2 add my $rec = $record->add("birth date", "1 Jan 2000"); Add a new record. Add a new record ($rec) as a sub-item of $record. Set its value to the last argument given. The first arguments may be specified as for record(). A new record will always be created for the last argument, and for any arguments for which the count is explicitly set to zero. If the new record does not take a value then do not supply one. This does mean that you cannot use the function with many arguments if the last one is a scalar, but not a value. In this case either specify the last argument as ["arg", 0], or add undef as the last argument. =head2 set my $rec = $record->set("birth date", "2 Jan 2000"); Set the value of a record. This is the same as add(), with the exception that a new record is not created for the last argument. =head2 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 $record-E{grammar}. Do this recursively. =head2 collect_xrefs $record->collect_xrefs($callback); Recursively collect all the xrefs. Called by Gedcom::collect_xrefs. $callback is not used yet. =head2 resolve_xref my $xref = $record->resolve_xref($value); See Gedcom::resolve_xrefs() =head2 resolve my @famc = $record->resolve $record->tag_value("FAMC"); For each argument, either return it or, if it an xref, return the referenced record. =head2 resolve_xrefs $record->resolve_xrefs($callback); See Gedcom::resolve_xrefs() =head2 unresolve_xrefs $record->unresolve_xrefs($callback); See Gedcom::unresolve_xrefs() =head2 validate_semantics return 0 unless $record->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. =head2 normalise_dates $record->normalise_dates($format); Change the format of all dates in the record. See the documentation for Gedcom::normalise_dates =head2 renumber $record->renumber($args); Renumber the record. See Gedcom::renumber(). =head2 child_value NOTE - This function is deprecated - use tag_value instead. my $child = $record->child_value("NAME"); =head2 child_values NOTE - This function is deprecated - use tag_value instead. my @children = $record->child_values("CHIL"); =head2 summary print $record->summary, "\n"; Return a line of text summarising the record. =head2 delete_record $record->delete_record($sub_record); Delete the specified sub-record from the record. =head2 Access functions All the Gedcom tag names can be used as function names. Depending on the context in which they are called, the functions return either an array of the specified sub-items, or the first specified sub-item. The descriptions of the tags, with spaces replaced by underscores, can also be used as function names. The function names can be of either, or mixed case. Unless you use the tag name, in either case, or the description in lower case, the function will not be pre-declared and you will need to qualify it or C. =cut Gedcom-1.19/CHANGES0000644000175000017500000002270212204002473012270 0ustar pjcjpjcjGedcom.pm history Release 1.19 - - Allow CONC and CONT on PAGE (Ken Williams) (github 2). - Make default grammar more lax but also include strict grammar file. - Make Text::Soundex a prerequisite. Release 1.18 - 24th January 2013 - Get dmake on Windows running again. Release 1.17 - 29th December 2012 - Lots of clean-ups (Brian Cassidy). - POD fixes (Brian Cassidy) (rt 31321). - Add half-sibling/-brothers/-sisters (Michael H. Ionescu) (github 1). - Make sex() tolerant of missing information (Michael H. Ionescu) (github 1). - Select correct grammar when adding items (rt 82196). - Some doc fixes (rt 76519). - Change and document method for specifying a top-level xref. - Always use correct grammar for notes (based on code from Jonathan Kamens) (rt 45391). - Clean up Makefile.PL (rt 6681). - Handle UTF-8 encoded files and BOMs (rt 79507). - Add grammar for version 5.5.1. Release 1.16 - 24th April 2009 - Allow family to be undef in children_statement in lines2perl. - Add basic web services. Release 1.15 - 3rd May 2005 - Update mailing list information. Release 1.14 - 5th April 2004 - Fix the test routine. Oops. - Don't lose the first line of level zero notes. Release 1.13 - 6th 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). 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.11 - 7th April 2002 - Improvements to the algorithm in Gedcom::Grammar::item(). 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 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. - 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 that are fixed now. Release 1.09 - 12th February 2001 - 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. - Add Gedcom::CGI and cgi-bin/gedcom.cgi. Release 1.08 - 8th May 2000 - Allow xrefs to match .+ instead of \w+\d+ - Make XML output valid. - Allow extra sub-items of a grammar structure. Release 1.07 - 14th March 2000 - Add functions to: Item.pm: item() full_value() - Get parse_grammar working again. - Add a test for parse_grammar. Release 1.06 - 13th February 2000 - Add functions to: Item.pm: get_item() Record.pm: record() get_record() get_value() tag_record() tag_value() delete_record() - Deprecate use of Item::get_child() - use Item::get_item() instead. - Deprecate use of Item::get_children() - use Item::get_item() instead. - Deprecate use of Record::child_value() - use Record::tag_value() instead. - Deprecate use of Record::child_values() - use Record::tag_value() instead. - Complete Lifelines::roman() using Roman.pm. - Add check for Roman.pm to Makefile.PL. - Add read_only option for lazy parsing. - Rename ged.vim to gedcom.vim and package it up for inclusion with Vim. - Restructure and abstract away some of the basic tests. - Add tests: t/Engine.pm t/Basic.pm t/read_only.t t/resolve.t t/resolve_read_only.t t/birthdates.t t/Lines.pm t/lines.t t/lines/lines.ll t/bias.t t/lines/bias.ll - Use "item" instaed of "child" to represent Gedcom hierarchies. - Raname Gedcom::Item::add_children() to Gedcom::Item::add_items() Gedcom::Item::skip_children() Gedcom::Item::skip_items() Gedcom::Item::delete_child() Gedcom::Item::delete_item() Gedcom::Item::delete_children() Gedcom::Item::delete_items() Gedcom::Item::next_record() Gedcom::Item::next_item() Gedcom::Grammar::child() Gedcom::Grammar::item() Gedcom::Grammar::children() Gedcom::Grammar::items() Gedcom::Grammar::valid_children() Gedcom::Grammar::valid_items() - Allow accessor functions in Gedcom::Item to set data too. - Bless appropriate objects into Gedcom::Event. - Add an experimental write_xml(). - Add tutorial section to documentation. Release 1.05 - 20th July 1999 - Add LifeLines.pm. - Add Event.pm. - Add functions to: Gedcom.pm: soundex() Item.pm: level() xref() tag() value() min() max() gedcom() file() line() Individual.pm: name() cased_name() surname() given_names() soundex() sex() older_siblings() younger_siblings() Family.pm: parents() number_of_children() - Change most functions in Individual and Family to check wantarray. - Have get_individual check xrefs and soundex. - Fix renumber error - xrefs are now calculated and then changed. - Change basic.t to reflect renumber fix. - Move normalise_dates from Item.pm to Record.pm. - Add AUTOLOAD function to Record.pm to provide access based on tag name or description. - Change lines2perl to use references to arrays and hashes. - Other major changes to lines2perl to increase functionality. - Change require 5.004 to require 5.005. - Add check for Text/Soundex.pm to Makefile.PL. Release 1.04 - 29th May 1999 - Improve default sort subroutine. - Include mailing list information. - Add lines2perl. - Improve Makefile.PL environment tests. - Work around IO::Handle::input_line_number bug. Release 1.03 - 13th May 1999 - Add Grammar::child() and Grammar::structure(). - Make valid_children more efficient and include min and max information. - Add validate_syntax() to Gedcom::Record.pm. - Rename Record::validate() to Record::validate_semantics(). - Add min(), max() and children() to Gedcom::Grammar.pm. - Add GEDC and SUBM to royal.ged to accommodate validate_syntax(). - Fix bug which prevented writing of @s around xref values. Release 1.02 - 5th May 1999 - 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(). 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 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.pm optional. Release 1.00 - Initial release - 8th March 1999 Gedcom-1.19/README0000644000175000017500000001015112204002474012151 0ustar pjcjpjcjNAME Gedcom - a module to manipulate Gedcom genealogy files Version 1.19 - 18th August 2013 DESCRIPTION Copyright 1998-2013, Paul Johnson (paul@pjcj.net) 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 This module provides for manipulation of Gedcom files. Gedcom is a format for storing genealogical information designed by The Church of Jesus Christ of Latter-Day Saints (http://www.lds.org). Information about Gedcom is available as a zip file at ftp://gedcom.org/pub/genealogy/gedcom/gedcom55.zip. Unfortunately, this is only usable if you can access a PC running Windows of some 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 Roman.pm to use the LifeLines function roman from lines2perl The Gedcom format is specified in a grammar file (gedcom-5.5.grammar). Gedcom.pm parses the grammar which is then used to validate and allow manipulation of the Gedcom file. I have only used Gedcom.pm with version 5.5 of the Gedcom grammar, which I had to modify slightly to correct a few errors. The advantage of this approach is that Gedcom.pm should be useful if the Gedcom grammar is ever updated. It also made the software easier to write, and probably more dependable too. I 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 documentation than the previous ones - but if you would like information feel free to send me mail or better still, ask on the mailing list. This module provides some functions which work over the entire Gedcom 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. 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. 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 unless you do some manual housekeeping. 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 would like to have some sort of an idea of the use this software is getting. Apart from being of interest to me, this will guide my 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 and if you use or are interested in this module I would encourage you to join the list. To subscribe send an empty message to perl-gedcom-subscribe@perl.org. 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 manipulate it. I find this to be a nice solution. Gedcom-1.19/tkged0000755000175000017500000010402312204002474012317 0ustar pjcjpjcj#!/usr/local/bin/perl -w # Copyright 1998-2013, Paul Johnson (paul@pjcj.net) # 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.19 - 18th August 2013 use strict; require 5.005; use diagnostics; use Tk::FileSelect; use Tk::Font; use Tk::Listbox; use Tk::WaitBox; use Tk; use Carp; use Data::Dumper; use Gedcom 1.19; use vars qw( $VERSION ); $VERSION = "1.19"; eval "use Date::Manip"; Date_Init("DateFormat=UK") if $INC{"Date/Manip.pm"}; my %Options = ( font_point => 240, font_width => "*", ); my %Colour_scheme = ( background => "grey75", foreground => "blue2", ); my $Grammar_file = "gedcom-5.5.grammar"; my $Grammar; my $Ged; my $Top; my $Rec; my $Fontname; # TODO - put in Gedcom.pm my %Tags = ( BAPL => "Baptism", BIRT => "Birth", BURI => "Burrial", CHR => "Christening", DEAT => "Death", ENDL => "Endownment", MARR => "Marriage", NAME => "Name", REFN => "Reference", SEX => "Sex", SLGC => "Sealing to Parents", TITL => "Title", FAMC => "Child of Family Id", FAMS => "Family Id", DATE => "Date", PLAC => "Place", COMM => "Comment", NOTE => "Note", ); main(); sub main() { $| = 1; $Top = MainWindow->new; $Top->geometry("900x400"); my %font_spec = ( # foundry => "adobe", family => "times", weight => "bold", slant => "r", point => $Options{font_point}, # space => "m", # registry => "iso8859", ); my $font = $Top->Font(%font_spec); confess "Cannot allocate font - try changing some parameters" unless $font; $Fontname = $font->Name; $Top->optionAdd('*font' => $Fontname); $Top->setPalette(%Colour_scheme); while (my($col, $val) = each %{$Top->Palette}) { # print "setting $col to $val\n"; $Top->optionAdd('*' . $col => $val); } $Top->bind("all", "", "Backspace"); create_windows(); load(shift @ARGV); # if @ARGV; MainLoop; } sub load($) { my ($gedcom_file) = @_; $Top->Busy; my $cont = 1; my $progress; $progress = $Top->WaitBox(-title => "Reading...", -txt1 => "", -canceltext => "Cancel", -cancelroutine => sub { $cont = 0 }); my $u = $progress->{SubWidget}{uframe}; my $utxt; my @pk = (-expand => 1, -fill => "both"); $u->pack(@pk); $u->Label(-textvariable => \$utxt)->pack(@pk); my $width = 700; my $height = 25; my $canv = $u->Canvas(-width => $width, -height => $height, -background => "red") ->pack(-expand => 0); $progress->Show; $Top->update; $Ged = Gedcom->new( # grammar_file => $Grammar_file, gedcom_file => $gedcom_file, callback => sub { my ($title, $txt1, $txt2, $current, $total) = @_; if ($total) { my $ratio = $current / $total; $utxt = sprintf("%5.2f%% complete", $ratio * 100); $canv->delete("all"); $canv->createLine(0, $height / 2, $ratio * $width, $height / 2, -width => $height, -fill => "green"); } $progress->configure(-title => $title, -txt1 => $txt1, -txt2 => $txt2); $Top->update; $progress->unShow unless $cont ||= (box("No", "Do you really want to cancel?", -title => "Cancel", -buttons => ["Yes", "No"]) eq "No"); $cont; }); $progress->unShow if $cont; my @individuals = $Ged->{record}->get_children("INDI"); if (@individuals) { show_record("", $individuals[0], "full"); } $Top->Unbusy; } sub save($) { my ($gedcom_file) = @_; $Top->Busy; $Top->update; $Ged->write($gedcom_file); $Top->Unbusy; } sub updown($$) { my ($list, $pos) = @_; $list->activate($pos =~ /^[+-]\d+$/ ? $list->index("active") + $pos : $pos); $list->see("active"); $list->selectionClear(0, "end"); $list->selectionSet("active") } sub select_record($) { my ($type) = @_; return undef unless $Ged->{record}; $Top->Busy; my @records = $Ged->{record}->get_children($type); # print "records are ", Dumper \@records; unless (exists $Top->{_box}) { my $box = $Top->{_box} = $Top->DialogBox(-default_button => "Ok", -title => "Select", -buttons => [ "Ok", "Cancel" ]); my $frame = $box->add("Frame")->pack(-fill => "both", -expand => 1); my $list = $frame->Scrolled("Listbox", -scrollbars => "w") ->pack(-fill => "both", -expand => 1); my $listbox = $Top->{_list} = $list->Subwidget("listbox"); my %font_spec = ( family => "courier", weight => "bold", slant => "r", point => $Options{font_point} * .75, ); my $font = $Top->Font(%font_spec); confess "Cannot allocate font - try changing some parameters" unless $font; $listbox->configure(-font => $font, -width => 65, -height => 20); $box->bind("" => sub { $box->{selected_button} = $listbox->curselection }); } $Top->{_list}->delete(0, "end"); for my $i (@records) { $Top->{_list}->insert("end", $i->summary) } updown($Top->{_list}, "+0"); $Top->Unbusy; my $i = $Top->{_box}->Show; return undef if $i eq "Cancel"; $i = $Top->{_list}->curselection if $i eq "Ok"; $records[$i]; } # TODO - put in Gedcom.pm sub get_tag($) { my ($tag) = @_; return $tag unless my ($t, $n) = $tag =~ /^([A-z]+)(\d*)$/; # print "Checking tag for <$t> <$n> => <$Tags{$t}>\n"; my $r = (exists($Tags{$t}) ? $Tags{$t} : $t) . $n; # print "got <$r>\n"; $r; } # TODO - put in Gedcom.pm sub get_name($) { my ($tag) = @_; # print "tag for $tag\n"; join(" ", map { get_tag($_) } split(/_/, $tag)); } sub create_items(%) { my (%a) = @_; my $height = $a{height} || 40; # print "lines is $a{canv}{_lines}\n"; my $y = $a{canv}{_lines}++ * ($height * 1.1); my $width = 850; $a{canv}->configure(-scrollregion => [0, 0, $width, $y + $height]); # print "size is ($width, $y + $height)\n"; my $x = 0; for my $item (@{$a{items}}) { my $tag = $item->{tag}; warn "no record for $tag" unless exists $a{canv}->{_ged}{$tag}; my $rec = $a{canv}->{_ged}{$tag}; if (exists $item->{widget}) { my $widget= $rec->{"_Frame"} = $a{canv}->Frame(-width => $width * $item->{relwidth}, -height => $height); my $w = $item->{widget}; my $bind = $rec->{"_$w"} = $widget->$w(%{$item->{options}}) ->pack(-expand => 1, -fill => "both"); $a{canv}->createWindow($width * $x, $y, -width => $width * $item->{relwidth}, -height => $height, -tags => [ $tag ], -anchor => "nw", -window => $widget); while (exists $item->{"bind"} && @{$item->{"bind"}}) { $bind->bind(splice @{$item->{"bind"}}, 0, 2); } } elsif (exists $item->{item}) { my $i = "create" . ucfirst $item->{item}; my $inc = $item->{item} eq "text" ? 8 : 0; my $t = "${tag}_$item->{item}"; my @tags = ($tag, $t); push (@tags, @{$item->{tags}}) if exists $item->{tags}; if ($item->{change}) { my $change = $tag . "_change"; push @tags, $change; ($rec->{_canvas_text} = $tag) =~ s/(NAME|XREF)1$/value/; # print "canvas text is $rec->{_canvas_text}\n"; } $a{canv}->$i($width * $x + $inc, $y + $inc, -tags => \@tags, -anchor => "nw", -font => $Fontname, -fill => $item->{colour} || "black", %{$item->{options}}); if (exists $item->{"bind"} && @{$item->{"bind"}}) { while (@{$item->{"bind"}}) { $a{canv}->bind(splice @{$item->{"bind"}}, 0, 3); } } } else { die "No widget or item specified for ", Dumper $item; } $x += $item->{relwidth}; $rec->{$tag =~ /_XREF1$/ ? "xref" : "value"} |= ""; # print "$w is ", $rec->{"_$w"}, # " and ", $Top->{_canv}{_ged}{$tag}{"_$w"}, "\n"; } confess "Width of $x should be 1" unless abs($x - 1) < 0.01; } sub create_record($$) { my ($canv, $tag) = @_; # print "creating record for $tag\n"; create_items ( canv => $canv, items => [ { tag => $tag, item => "text", options => { -text => get_name($tag) }, "bind" => [ $tag, "<1>" => sub { print "qaz\n" } ], relwidth => 0.25, }, { widget => "Entry", tag => $tag, options => {}, relwidth => 0.75, }, ] ); set_entry($tag); } sub create_person($$$) { my ($canv, $label, $tag) = @_; my $ref = "${tag}_XREF1"; # print "getting $ref\n"; my $xref = $canv->{_ged}{$ref}{xref}; my $me = $xref ? $Ged->{xrefs}{$canv->{_ged}{$ref}{xref}} : undef; # print "I am ", Dumper $me; create_items ( canv => $canv, items => [ { tag => "${tag}_NAME1", item => "text", tags => [ $tag, "${tag}_title" ], options => { -text => $label }, relwidth => 0.15, }, $tag ? { tag => "${tag}_NAME1", item => "text", tags => [ $tag, "${tag}_value" ], change => 1, options => { -text => $me ? $me->child_value("NAME1") : ""}, colour => "blue", "bind" => [ $tag, "<1>" => sub { my $me = $Ged->{xrefs}{$canv->{_ged}{"${tag}_XREF1"}{xref}}; # print "me is $me\n"; show_record("", $me, "full"); }, $tag, "<3>" => sub { my $ind = select_record("INDI"); # print "ind is ", Dumper $ind; return unless $ind; if (my ($fam, $person) = $tag =~ /^(_FAM[CS]\d*)_([^_]+)/) { $canv->itemconfigure("${tag}_XREF1_change", -text => $ind->{xref}); $canv->itemconfigure("${tag}_NAME1_change", -text => $ind->child_value("NAME1")); } record_changed(); }, $tag, "" => sub { my $c = shift; $canv->itemconfigure("${tag}_title", -fill => "red"); }, $tag, "" => sub { my $c = shift; $canv->itemconfigure("${tag}_title", -fill => "black"); }, ], relwidth => 0.65, } : { tag => "${tag}_NAME1", widget => "Entry", options => {}, relwidth => 0.65, }, { tag => "${tag}_XREF1", item => "text", tags => [ $tag, "${tag}_title" ], options => { -text => "Id" }, relwidth => 0.05, }, $tag ? { tag => "${tag}_XREF1", item => "text", tags => [ $tag, "${tag}_value" ], change => 1, options => { -text => $me ? $me->{xref} : "" }, colour => "blue", relwidth => 0.15, } : { tag => "${tag}_XREF1", widget => "Entry", options => {}, relwidth => 0.15, }, ] ); } sub create_event($$$) { my ($canv, $label, $tag) = @_; create_items ( canv => $canv, items => [ { tag => "${tag}_DATE1", item => "text", options => { -text => $label }, relwidth => 0.15, }, { widget => "Entry", tag => "${tag}_DATE1", options => {}, relwidth => 0.2, }, { tag => "${tag}_PLAC1", item => "text", options => { -text => "At" }, relwidth => 0.05, }, { widget => "Entry", tag => "${tag}_PLAC1", options => {}, relwidth => 0.6, }, ] ); } sub create_windows() { $Top->Busy; my $top_fr = $Top->Frame->pack(-fill => "both", -expand => 1); my $menu_fr = $Top->{_menu_fr} = $top_fr->Frame(-relief => "raised", -borderwidth => 5) ->pack(-fill => "x", -expand => 0); my $main_fr = $top_fr->Frame->pack(-fill => "both", -expand => 1); my $load = sub { my $gedcom_file = $Top->FileSelect(-filter => "*.ged")->Show or return; load($gedcom_file); }; my $save = sub { save_changes(); record_changed(); my $gedcom_file = $Top->FileSelect(-filter => "*.ged")->Show or return; save($gedcom_file); }; my $quit = sub { exit; }; my $iselect = sub { save_changes(); show_record("", select_record("INDI"), "full"); }; my $inew = sub { save_changes(); my $max = 0; for ($Ged->{record}->get_children("INDI")) { if (my ($val) = $_->{xref} =~ /I(\d+)/) { $max = $val if $val > $max; } } $max++; my $indi_id = "I$max"; my $rec = Gedcom::Record->new ( tag => "INDI", xref => $indi_id, grammar => $Ged->{record}{grammar}->child("INDI"), ); add_record($rec, "_NAME1"); add_record($rec, "_BIRT1_DATE1"); add_record($rec, "_BIRT1_PLAC1"); # print "new record is ", Dumper $rec; splice @{$Ged->{record}{children}}, -1, 0, $rec; $Ged->{xrefs}{$rec->{xref}} = $rec; show_record("", $rec, "full"); }; my $idelete = sub { if (box("No", "Are you sure you want to delete this record?", -title => "Delete record", -buttons => ["Yes", "No"]) eq "Yes") { my $i = 0; for (; $i < @{$Ged->{record}{children}}; $i++) { last if exists $Ged->{record}{children}[$i]{xref} && $Ged->{record}{children}[$i]{xref} eq $Rec->{xref}; } unless ($i < @{$Ged->{record}{children}}) { box("Whoops", "I can't find record $Rec->{xref}", -title => "Unknown record id"); return; } delete $Ged->{xrefs}{$Rec->{xref}}; splice @{$Ged->{record}{children}}, $i, 1; for my $fam ($Ged->{record}->get_children("FAM")) { my $i = 0; for (; $i < @{$fam->{children}}; $i++) { # print "$fam->{tag} $fam->{children}[$i]{tag} ", # "checking $fam->{children}[$i]{value} eq $Rec->{xref}\n"; last if exists $fam->{children}[$i]{value} && $fam->{children}[$i]{value} eq $Rec->{xref}; } if ($i < @{$fam->{children}}) { splice @{$fam->{children}}, $i, 1; } } my @individuals = $Ged->{record}->get_children("INDI"); if (@individuals) { show_record("", $individuals[0], "full", "no_save"); } } }; my $rsave = sub { save_changes("no_ask"); record_changed(); }; my $fselect = sub { save_changes(); show_record("", select_record("FAM"), "full"); }; my $file_menu = $Top->{_file_menu} = $menu_fr->Menubutton(-text => "File", -underline => 0) ->pack(-side => "left"); $file_menu->command(-label => "Load", -underline => 0, -command => $load); $Top->bind("", $load); $file_menu->command(-label => "Save", -underline => 2, -command => $save); $Top->bind("", $save); $file_menu->command(-label => "Quit", -underline => 0, -command => $quit); $Top->bind("", $quit); my $ind_menu = $Top->{_ind_menu} = $menu_fr->Menubutton(-text => "Individual", -underline => 0) ->pack(-side => "left"); $ind_menu->command(-label => "Select", -underline => 0, -command => $iselect); $Top->bind("", $iselect); $ind_menu->command(-label => "New", -underline => 0, -command => $inew); $Top->bind("", $inew); $ind_menu->command(-label => "Save", -underline => 2, -command => $rsave); $Top->bind("", $rsave); $ind_menu->command(-label => "Delete", -underline => 0, -command => $idelete); $Top->bind("", $rsave); my $fam_menu = $Top->{_fam_menu} = $menu_fr->Menubutton(-text => "Family", -underline => 5) ->pack(-side => "left"); $fam_menu->command(-label => "Select", -underline => 0, -command => $fselect); $Top->bind("", $fselect); $fam_menu->command(-label => "Save", -underline => 2, -command => $rsave); # $Top->bind("