File Coverage

blib/lib/Gedcom.pm
Criterion Covered Total %
statement 275 294 93.5
branch 73 112 65.1
condition 26 53 49.0
subroutine 41 50 82.0
pod 18 26 69.2
total 433 535 80.9


line stmt bran cond sub pod time code
1             # Copyright 1998-2019, Paul Johnson (paul@pjcj.net)
2              
3             # This software is free. It is licensed under the same terms as Perl itself.
4              
5             # The latest version of this software should be available from my homepage:
6             # http://www.pjcj.net
7              
8             # documentation at __END__
9              
10 11     11   168568 use strict;
  11         80  
  11         380  
11              
12             require 5.005;
13              
14             package Gedcom;
15              
16 11     11   51 use Carp;
  11         16  
  11         587  
17 11     11   5799 use Data::Dumper;
  11         65261  
  11         652  
18 11     11   4094 use FileHandle;
  11         92146  
  11         56  
19              
20 11     11   3377 BEGIN { eval "use Text::Soundex" } # We'll use this if it is available
  11     11   4705  
  11         24976  
  11         1236  
21              
22 11     11   70 use vars qw($VERSION $AUTOLOAD %Funcs);
  11         24  
  11         3837  
23              
24             my $Tags;
25             my %Top_tag_order;
26              
27             BEGIN {
28 11     11   39 $VERSION = "1.22";
29              
30 11         13599 $Tags = {
31             ABBR => "Abbreviation",
32             ADDR => "Address",
33             ADOP => "Adoption",
34             ADR1 => "Address1",
35             ADR2 => "Address2",
36             AFN => "Afn",
37             AGE => "Age",
38             AGNC => "Agency",
39             ALIA => "Alias",
40             ANCE => "Ancestors",
41             ANCI => "Ances Interest",
42             ANUL => "Annulment",
43             ASSO => "Associates",
44             AUTH => "Author",
45             BAPL => "Baptism-LDS",
46             BAPM => "Baptism",
47             BARM => "Bar Mitzvah",
48             BASM => "Bas Mitzvah",
49             BIRT => "Birth",
50             BLES => "Blessing",
51             BLOB => "Binary Object",
52             BURI => "Burial",
53             CALN => "Call Number",
54             CAST => "Caste",
55             CAUS => "Cause",
56             CENS => "Census",
57             CHAN => "Change",
58             CHAR => "Character",
59             CHIL => "Child",
60             CHR => "Christening",
61             CHRA => "Adult Christening",
62             CITY => "City",
63             CONC => "Concatenation",
64             CONF => "Confirmation",
65             CONL => "Confirmation L",
66             CONT => "Continued",
67             COPR => "Copyright",
68             CORP => "Corporate",
69             CREM => "Cremation",
70             CTRY => "Country",
71             DATA => "Data",
72             DATE => "Date",
73             DEAT => "Death",
74             DESC => "Descendants",
75             DESI => "Descendant Int",
76             DEST => "Destination",
77             DIV => "Divorce",
78             DIVF => "Divorce Filed",
79             DSCR => "Phy Description",
80             EDUC => "Education",
81             EMIG => "Emigration",
82             ENDL => "Endowment",
83             ENGA => "Engagement",
84             EVEN => "Event",
85             FAM => "Family",
86             FAMC => "Family Child",
87             FAMF => "Family File",
88             FAMS => "Family Spouse",
89             FCOM => "First Communion",
90             FILE => "File",
91             FORM => "Format",
92             GEDC => "Gedcom",
93             GIVN => "Given Name",
94             GRAD => "Graduation",
95             HEAD => "Header",
96             HUSB => "Husband",
97             IDNO => "Ident Number",
98             IMMI => "Immigration",
99             INDI => "Individual",
100             LANG => "Language",
101             LEGA => "Legatee",
102             MARB => "Marriage Bann",
103             MARC => "Marr Contract",
104             MARL => "Marr License",
105             MARR => "Marriage",
106             MARS => "Marr Settlement",
107             MEDI => "Media",
108             NAME => "Name",
109             NATI => "Nationality",
110             NATU => "Naturalization",
111             NCHI => "Children_count",
112             NICK => "Nickname",
113             NMR => "Marriage_count",
114             NOTE => "Note",
115             NPFX => "Name_prefix",
116             NSFX => "Name_suffix",
117             OBJE => "Object",
118             OCCU => "Occupation",
119             ORDI => "Ordinance",
120             ORDN => "Ordination",
121             PAGE => "Page",
122             PEDI => "Pedigree",
123             PHON => "Phone",
124             PLAC => "Place",
125             POST => "Postal_code",
126             PROB => "Probate",
127             PROP => "Property",
128             PUBL => "Publication",
129             QUAY => "Quality Of Data",
130             REFN => "Reference",
131             RELA => "Relationship",
132             RELI => "Religion",
133             REPO => "Repository",
134             RESI => "Residence",
135             RESN => "Restriction",
136             RETI => "Retirement",
137             RFN => "Rec File Number",
138             RIN => "Rec Id Number",
139             ROLE => "Role",
140             SEX => "Sex",
141             SLGC => "Sealing Child",
142             SLGS => "Sealing Spouse",
143             SOUR => "Source",
144             SPFX => "Surn Prefix",
145             SSN => "Soc Sec Number",
146             STAE => "State",
147             STAT => "Status",
148             SUBM => "Submitter",
149             SUBN => "Submission",
150             SURN => "Surname",
151             TEMP => "Temple",
152             TEXT => "Text",
153             TIME => "Time",
154             TITL => "Title",
155             TRLR => "Trailer",
156             TYPE => "Type",
157             VERS => "Version",
158             WIFE => "Wife",
159             WILL => "Will",
160             };
161              
162 11         62 %Top_tag_order = (
163             HEAD => 1,
164             SUBM => 2,
165             INDI => 3,
166             FAM => 4,
167             NOTE => 5,
168             REPO => 6,
169             SOUR => 7,
170             TRLR => 8,
171             );
172              
173 11         68 while (my ($tag, $name) = each (%$Tags)) {
174 1419         4229 $Funcs{$tag} = $Funcs{lc $tag} = $tag;
175 1419 50       1769 if ($name) {
176 1419         1798 $name =~ s/ /_/g;
177 1419         5451 $Funcs{lc $name} = $tag;
178             }
179             }
180             }
181              
182       0     sub DESTROY {}
183              
184             sub AUTOLOAD {
185 10     10   595 my ($self) = @_; # don't change @_ because of the goto
186 10         21 my $func = $AUTOLOAD;
187             # print "autoloading $func\n";
188 10         62 $func =~ s/^.*:://;
189 10         19 my $tag;
190             croak "Undefined subroutine $func called"
191             if $func !~ /^(add|get)_(.*)$/ ||
192             !($tag = $Funcs{lc $2}) ||
193 10 50 33     121 !exists $Top_tag_order{$tag};
      33        
194 11     11   84 no strict "refs";
  11         18  
  11         4918  
195 10 100       38 if ($1 eq "add") {
196             *$func = sub {
197 12     12   17 my $self = shift;
198 12         19 my ($arg, $val) = @_;
199 12         12 my $xref;
200 12 100       22 if (ref $arg) {
201 1         2 $xref = $arg->{xref};
202             } else {
203 11         12 $val = $arg;
204             }
205 12         26 my $record = $self->add_record(tag => $tag, val => $val);
206 12 100 100     32 if (defined $val && $tag eq "NOTE") {
207 2         3 $record->{value} = $val;
208             }
209 12 100       39 $xref = $tag eq "SUBM" ? "SUBM" : substr $tag, 0, 1
    100          
210             unless defined $xref;
211 12 100       39 unless ($tag =~ /^(HEAD|TRLR)$/) {
212 10 50       44 croak "Invalid xref $xref requested in $func"
213             unless $xref =~ /^[^\W\d_]+(\d*)$/;
214 10 100       36 $xref = $self->next_xref($xref) unless length $1;
215 10         25 $record->{xref} = $xref;
216 10         24 $self->{xrefs}{$xref} = $record;
217             }
218             $record
219 6         37 };
  12         61  
220             } else {
221             *$func = sub {
222 4     4   9 my $self = shift;
223 4         12 my ($xref) = @_;
224 4         10 my $nxr = !defined $xref;
225 584 100 33     1009 my @a = grep { $_->{tag} eq $tag && ($nxr || $_->{xref} eq $xref) }
226 4         15 @{$self->{record}->_items};
  4         31  
227 4 50       21 wantarray ? @a : $a[0]
228 4         30 };
229             }
230 10         34 goto &$func
231             }
232              
233 11     11   4364 use Gedcom::Grammar 1.22;
  11         160  
  11         447  
234 11     11   4201 use Gedcom::Individual 1.22;
  11         185  
  11         432  
235 11     11   4041 use Gedcom::Family 1.22;
  11         156  
  11         333  
236 11     11   3592 use Gedcom::Event 1.22;
  11         146  
  11         3000  
237              
238             sub new {
239 8     8 1 340076 my $proto = shift;
240 8   33     79 my $class = ref($proto) || $proto;
241 8 50       74 @_ = (gedcom_file => @_) if @_ == 1;
242 8         92 my $self = {
243             records => [],
244             tags => $Tags,
245             read_only => 0,
246             types => {},
247             xrefs => {},
248             encoding => "ansel",
249             @_
250             };
251              
252             # TODO - find a way to do this nicely for different grammars
253 8         35 $self->{types}{INDI} = "Individual";
254 8         25 $self->{types}{FAM} = "Family";
255 8         320 $self->{types}{$_} = "Event" for qw(
256             ADOP ANUL BAPM BARM BASM BIRT BLES BURI CAST CENS CENS CHR CHRA CONF
257             CREM DEAT DIV DIVF DSCR EDUC EMIG ENGA EVEN EVEN FCOM GRAD IDNO IMMI
258             MARB MARC MARL MARR MARS NATI NATU NCHI NMR OCCU ORDN PROB PROP RELI
259             RESI RETI SSN WILL
260             );
261 8         27 bless $self, $class;
262              
263             # first read in the grammar
264 8         18 my $grammar;
265 8 100       72 if (defined $self->{grammar_file}) {
266 1         2 my $version;
267 1 50       2 if (defined $self->{grammar_version}) {
268 0         0 $version = $self->{grammar_version};
269             } else {
270 1         9 ($version) = $self->{grammar_file} =~ /(\d+(\.\d+)*)/;
271             }
272 1 50       3 die "version must be a GEDCOM version number\n" unless $version;
273             return undef unless
274             $grammar = Gedcom::Grammar->new(
275             file => $self->{grammar_file},
276             version => $version,
277             callback => $self->{callback}
278 1 50       13 );
279             } else {
280 7 100       41 $self->{grammar_version} = 5.5 unless defined $self->{grammar_version};
281 7         59 (my $v = $self->{grammar_version}) =~ tr/./_/;
282 7         30 my $g = "Gedcom::Grammar_$v";
283 7     7   4658 eval "use $g $VERSION";
  7         136  
  7         182  
  7         601  
284 7 50       32 die $@ if $@;
285 11     11   72 no strict "refs";
  11         17  
  11         24872  
286 7 50       11 return undef unless $grammar = ${$g . "::grammar"};
  7         50  
287             }
288 8         51 my @c = ($self->{grammar} = $grammar);
289 8         38 while (@c) {
290 48         80 @c = map { $_->{top} = $grammar; @{$_->{items}} } @c;
  3256         3313  
  3256         2771  
  3256         3817  
291             }
292              
293             # now read in or create the GEDCOM file
294             return undef unless
295             my $r = $self->{record} = Gedcom::Record->new(
296             defined $self->{gedcom_file} ? (file => $self->{gedcom_file}) : (),
297             line => 0,
298             tag => "GEDCOM",
299             grammar => $grammar->structure("GEDCOM"),
300             gedcom => $self,
301             callback => $self->{callback},
302 8 100       93 );
    50          
303              
304 8 100       54 unless (defined $self->{gedcom_file}) {
305              
306             # Add the required elements, unless they are already there.
307              
308 1 50       8 unless ($r->get_record("head")) {
309 1         2 my $me = "Unknown user";
310 1         2 my $login = $me;
311 1 50 0     839 if ($login = getlogin || (getpwuid($<))[0] ||
312             $ENV{USER} || $ENV{LOGIN}) {
313 1         3 my $name;
314 1         2 eval { $name = (getpwnam($login))[6] };
  1         70  
315 1   33     7 $me = $name || $login;
316             }
317 1         32 my $date = localtime;
318              
319 1         4 my ($l0, $l1, $l2, $l3);
320 1         11 $l0 = $self->add_header;
321 1         4 $l1 = $l0->add("SOUR", "Gedcom.pm");
322 1         4 $l1->add("NAME", "Gedcom.pm");
323 1         4 $l1->add("VERS", $VERSION);
324 1         7 $l2 = $l1->add("CORP", "Paul Johnson");
325 1         4 $l2->add("ADDR", "http://www.pjcj.net");
326 1         7 $l2 = $l1->add("DATA");
327 1         8 $l3 = $l2->add(
328             "COPR",
329             'Copyright 1998-2019, Paul Johnson (paul@pjcj.net)'
330             );
331 1         3 $l1 = $l0->add("NOTE", "");
332 1         6 for (split /\n/, <<'EOH')
333             This output was generated by Gedcom.pm.
334             Gedcom.pm is Copyright 1998-2019, Paul Johnson (paul@pjcj.net)
335             Version 1.22 - 15th November 2019
336              
337             Gedcom.pm is free. It is licensed under the same terms as Perl itself.
338              
339             The latest version of Gedcom.pm should be available from my homepage:
340             http://www.pjcj.net
341             EOH
342             {
343 8         16 $l1->add("CONT", $_);
344             };
345 1         4 $l1 = $l0->add("GEDC");
346 1         4 $l1->add("VERS", $self->{grammar}{version});
347 1         4 $l1->add("FORM", "LINEAGE-LINKED");
348 1         4 $l0->add("DATE", $date);
349 1   50     8 $l0->add("CHAR", uc ($self->{encoding} || "ansel"));
350 1         3 my $s = $r->get_record("subm");
351 1 50       3 unless ($s) {
352 1         10 $s = $self->add_submitter;
353 1         4 $s->add("NAME", $me);
354             }
355 1         10 $l0->add("SUBM", $s->xref);
356             }
357              
358 1 50       4 $self->add_trailer unless $r->get_record("trlr");
359             }
360              
361 8         46 $self->collect_xrefs;
362              
363 8         44 $self
364             }
365              
366             sub set_encoding {
367 7     7 1 31 my $self = shift;
368 7         37 ($self->{encoding}) = @_;
369             }
370              
371             sub write {
372 7     7 1 705 my $self = shift;
373 7 50       27 my $file = shift or die "No filename specified";
374 7         16 my $flush = shift;
375 7 50       91 $self->{fh} = FileHandle->new($file, "w") or die "Can't open $file: $!";
376             binmode $self->{fh}, ":encoding(UTF-8)"
377 7 50 33     1752 if $self->{encoding} eq "utf-8" && $] >= 5.8;
378 7         125 $self->{record}->write($self->{fh}, -1, $flush);
379 7 50       57 $self->{fh}->close or die "Can't close $file: $!";
380             }
381              
382             sub write_xml {
383 0     0 1 0 my $self = shift;
384 0 0       0 my $file = shift or die "No filename specified";
385 0 0       0 $self->{fh} = FileHandle->new($file, "w") or die "Can't open $file: $!";
386             binmode $self->{fh}, ":encoding(UTF-8)"
387 0 0 0     0 if $self->{encoding} eq "utf-8" && $] >= 5.8;
388 0         0 $self->{fh}->print(<<'EOH');
389            
390              
391             \n\n");
404 0         0 $self->{record}->write_xml($self->{fh});
405 0 0       0 $self->{fh}->close or die "Can't close $file: $!";
406             }
407              
408             sub add_record {
409 12     12 1 13 my $self = shift;
410 12         47 $self->{record}->add_record(@_);
411             }
412              
413             sub collect_xrefs {
414 21     21 1 50 my $self = shift;
415 21         50 my ($callback) = @_;
416 21         600 $self->{xrefs} = {};
417 21         112 $self->{record}->collect_xrefs($callback);
418             }
419              
420             sub resolve_xref {
421 29631     29631 1 35088 my $self = shift;;
422 29631         36839 my ($x) = @_;
423 29631         26278 my $xref;
424 29631 50       57798 $xref = $self->{xrefs}{$x =~ /^\@(.+)\@$/ ? $1 : $x} if defined $x;
    100          
425 29631         51627 $xref
426             }
427              
428             sub resolve_xrefs {
429 19     19 1 2578 my $self = shift;
430 19         56 my ($callback) = @_;
431 19         97 $self->{record}->resolve_xrefs($callback);
432             }
433              
434             sub unresolve_xrefs {
435 12     12 1 4982 my $self = shift;
436 12         30 my ($callback) = @_;
437 12         68 $self->{record}->unresolve_xrefs($callback);
438             }
439              
440             sub validate {
441 61     61 1 4572 my $self = shift;
442 61         139 my ($callback) = @_;
443 61         150 $self->{validate_callback} = $callback;
444 61         313 my $ok = $self->{record}->validate_syntax;
445 61         214 for my $item (@{$self->{record}->_items}) {
  61         204  
446 8770 50       15278 $ok = 0 unless $item->validate_semantics;
447             }
448             $ok
449 61         1023 }
450              
451             sub normalise_dates {
452 6     6 1 2753 my $self = shift;
453 6         49 $self->{record}->normalise_dates(@_);
454             }
455              
456             sub renumber {
457 13     13 1 856 my $self = shift;
458 13         38 my (%args) = @_;
459 13         77 $self->resolve_xrefs;
460              
461             # initially, renumber any records passed in
462 13         26 for my $xref (@{$args{xrefs}}) {
  13         64  
463             $self->{xrefs}{$xref}->renumber(\%args, 1)
464 6 50       140 if exists $self->{xrefs}{$xref};
465             }
466              
467             # now, renumber any records left over
468 13         33 $_->renumber(\%args, 1) for @{$self->{record}->_items};
  13         58  
469              
470             # actually change the xref
471 13         37 for my $record (@{$self->{record}->_items}) {
  13         53  
472 1762         2479 $record->{xref} = delete $record->{new_xref};
473             delete $record->{recursed}
474 1762         1921 }
475              
476             # and update the xrefs
477 13         81 $self->collect_xrefs;
478              
479 13         202 %args
480             }
481              
482             sub sort_sub {
483             # subroutine to sort on tag order first, and then on xref
484              
485             my $t = sub {
486 6840     6840   7393 my ($r) = @_;
487 6840 50       8989 return -2 unless defined $r->{tag};
488 6840 50       12561 exists $Top_tag_order{$r->{tag}} ? $Top_tag_order{$r->{tag}} : -1
489 7     7 1 71 };
490              
491             my $x = sub {
492 6206     6206   6774 my ($r) = @_;
493 6206 50       7628 return -2 unless defined $r->{xref};
494 6206         9065 $r->{xref} =~ /(\d+)/;
495 6206 50       13826 defined $1 ? $1 : -1
496 7         43 };
497              
498             sub {
499 3420 100   3420   4886 $t->($a) <=> $t->($b)
500             ||
501             $x->($a) <=> $x->($b)
502             }
503 7         50 }
504              
505             sub order {
506 7     7 1 4465 my $self = shift;
507 7   33     52 my $sort_sub = shift || sort_sub; # use default sort unless one passed in
508 7         18 @{$self->{record}{items}} = sort $sort_sub @{$self->{record}->_items}
  7         232  
  7         36  
509             }
510              
511             sub items {
512 130     130 0 197 my $self = shift;
513 130         179 @{$self->{record}->_items}
  130         429  
514             }
515              
516 0     0 0 0 sub heads { grep $_->tag eq "HEAD", shift->items }
517 0     0 0 0 sub submitters { grep $_->tag eq "SUBM", shift->items }
518 94     94 1 9166 sub individuals { grep ref eq "Gedcom::Individual", shift->items }
519 36     36 1 3578 sub families { grep ref eq "Gedcom::Family", shift->items }
520 0     0 0 0 sub notes { grep $_->tag eq "NOTE", shift->items }
521 0     0 0 0 sub repositories { grep $_->tag eq "REPO", shift->items }
522 0     0 0 0 sub sources { grep $_->tag eq "SOUR", shift->items }
523 0     0 0 0 sub trailers { grep $_->tag eq "TRLR", shift->items }
524              
525             sub get_individual {
526 86     86 1 11406 my $self = shift;
527 86         225 my $name = "@_";
528 86         144 my $all = wantarray;
529 86         125 my @i;
530              
531 86   66     245 my $i = $self->resolve_xref($name) || $self->resolve_xref(uc $name);
532 86 100       201 if ($i) {
533 30 50       116 return $i unless $all;
534 0         0 push @i, $i;
535             }
536              
537             # search for the name in the specified order
538             my $ordered = sub {
539 423     423   1648 my ($n, @ind) = @_;
540 423 50       616 map { $_->[1] } grep { $_ && $_->[0] =~ $n } @ind
  146         391  
  37611         103669  
541 56         335 };
542              
543             # search for the name in any order
544             my $unordered = sub {
545 198     198   788 my ($names, $t, @ind) = @_;
546 222         526 map { $_->[1] } grep {
547 198         296 my $i = $_->[0];
  18414         19018  
548 18414         17284 my $r = 1;
549 18414         19598 for my $n (@$names) {
550             # remove matches as they are found
551             # we don't want to match the same name twice
552 18858 100       43221 last unless $r = $i =~ s/$n->[$t]//;
553             }
554             $r
555 18414         25505 }
556             @ind;
557 56         199 };
558              
559             # look for various matches in decreasing order of exactitude
560 56         153 my @individuals = $self->individuals;
561              
562             # Store the name with the individual to avoid continually recalculating it.
563             # This is a bit like a Schwartzian transform, with a grep instead of a sort.
564             my @ind =
565 56 50       277 map [do { my $n = $_->tag_value("NAME"); defined $n ? $n : "" } => $_],
  5208         8004  
  5208         11011  
566             @individuals;
567              
568 56         1150 for my $n (map { qr/^$_$/, qr/\b$_\b/, $_ } map { $_, qr/$_/i } qr/\Q$name/)
  112         1236  
  56         274  
569             {
570 327         687 push @i, $ordered->($n, @ind);
571 327 100 100     826 return $i[0] if !$all && @i;
572             }
573              
574             # create an array with one element per name
575             # each element is an array of REs in decreasing order of exactitude
576 54         314 my @names = map [ map { qr/\b$_\b/, $_ } map { qr/$_/, qr/$_/i } "\Q$_" ],
  216         1551  
  108         1152  
577             split / /, $name;
578 54         119 for my $t (0 .. $#{$names[0]}) {
  54         217  
579 198         518 push @i, $unordered->(\@names, $t, @ind);
580 198 100 66     632 return $i[0] if !$all && @i;
581             }
582              
583             # check soundex
584 48 100       100 my @sdx = map { my $s = $_->soundex; $s ? [ $s => $_ ] : () } @individuals;
  4464         7655  
  4464         9913  
585              
586 48         137 my $soundex = soundex($name);
587 48   33     125 for my $n ( map { qr/$_/ } $name, ($soundex || ()) ) {
  96         1023  
588 96         256 push @i, $ordered->($n, @sdx);
589 96 50 33     257 return $i[0] if !$all && @i;
590             }
591              
592 48 50       179 return undef unless $all;
593              
594 48         80 my @s;
595             my %s;
596 48         83 for (@i) {
597 360 100       589 unless (exists $s{$_->{xref}}) {
598 114         127 push @s, $_;
599 114         224 $s{$_->{xref}}++;
600             }
601             }
602              
603             @s
604 48         1916 }
605              
606             sub next_xref {
607 45     45 1 89 my $self = shift;
608 45         104 my ($type) = @_;
609 45         779 my $re = qr/^$type(\d+)$/;
610 45         79 my $last = 0;
611 45         65 for my $c (@{$self->{record}->_items}) {
  45         136  
612 5318 100 100     19955 $last = $1 if defined $c->{xref} and $c->{xref} =~ /$re/ and $1 > $last;
      100        
613             }
614 45         357 $type . ++$last
615             }
616              
617             sub top_tag {
618 0     0 0   my $self = shift;
619 0           my ($tag) = @_;
620 0           $Top_tag_order{$tag}
621             }
622              
623             "
624             But take your time, think a lot
625             Think of everything you've got
626             For you will still be here tomorrow
627             But your dreams may not
628             "
629              
630             __END__