File Coverage

blib/lib/Genealogy/Gedcom/Date.pm
Criterion Covered Total %
statement 180 207 86.9
branch 99 136 72.7
condition 25 36 69.4
subroutine 22 24 91.6
pod 6 11 54.5
total 332 414 80.1


line stmt bran cond sub pod time code
1             package Genealogy::Gedcom::Date;
2              
3 5     5   11473 use strict;
  5         7  
  5         105  
4 5     5   897 use utf8;
  5         17  
  5         16  
5 5     5   98 use warnings qw(FATAL utf8); # Fatalize encoding glitches.
  5         7  
  5         161  
6              
7 5     5   21 use Config;
  5         5  
  5         200  
8              
9 5     5   1524 use Data::Dumper::Concise; # For Dumper().
  5         28347  
  5         254  
10              
11 5     5   1784 use Genealogy::Gedcom::Date::Actions;
  5         8  
  5         116  
12              
13 5     5   3226 use Log::Handler;
  5         130217  
  5         21  
14              
15 5     5   2220 use Marpa::R2;
  5         493496  
  5         72  
16              
17 5     5   2858 use Moo;
  5         44905  
  5         25  
18              
19 5     5   6168 use Try::Tiny;
  5         7  
  5         289  
20              
21 5     5   2672 use Types::Standard qw/Any ArrayRef Bool Int HashRef Str/;
  5         239331  
  5         44  
22              
23             has bnf =>
24             (
25             default => sub{return ''},
26             is => 'rw',
27             isa => Str,
28             required => 0,
29             );
30              
31             has _calendar =>
32             (
33             default => sub{return 'Gregorian'},
34             is => 'rw',
35             isa => Str,
36             required => 0,
37             );
38              
39             has canonical =>
40             (
41             default => sub{return 0},
42             is => 'rw',
43             isa => Int,
44             required => 0,
45             );
46              
47             has date =>
48             (
49             default => sub{return ''},
50             is => 'rw',
51             isa => Str,
52             required => 0,
53             );
54              
55             has error =>
56             (
57             default => sub{return ''},
58             is => 'rw',
59             isa => Str,
60             required => 0,
61             );
62              
63             has grammar =>
64             (
65             default => sub {return ''},
66             is => 'rw',
67             isa => Any,
68             required => 0,
69             );
70              
71             has logger =>
72             (
73             default => sub{return undef},
74             is => 'rw',
75             isa => Any,
76             required => 0,
77             );
78              
79             has maxlevel =>
80             (
81             default => sub{return 'notice'},
82             is => 'rw',
83             isa => Str,
84             required => 0,
85             );
86              
87             has minlevel =>
88             (
89             default => sub{return 'error'},
90             is => 'rw',
91             isa => Str,
92             required => 0,
93             );
94              
95             has recce =>
96             (
97             default => sub{return ''},
98             is => 'rw',
99             isa => Any,
100             required => 0,
101             );
102              
103             has result =>
104             (
105             default => sub{return []},
106             is => 'rw',
107             isa => ArrayRef,
108             required => 0,
109             );
110              
111             our $VERSION = '2.08';
112              
113             # ------------------------------------------------
114              
115             sub BUILD
116             {
117 46     46 0 744 my($self) = @_;
118              
119 46 50       680 if (! defined $self -> logger)
120             {
121 46         424 $self -> logger(Log::Handler -> new);
122 46         4319 $self -> logger -> add
123             (
124             screen =>
125             {
126             maxlevel => $self -> maxlevel,
127             message_layout => '%m',
128             minlevel => $self -> minlevel,
129             utf8 => 1,
130             }
131             );
132             }
133              
134             # Initialize the action class via global variables - Yuk!
135             # The point is that we don't create an action instance.
136             # Marpa creates one but we can't get our hands on it.
137              
138 46         28996 $Genealogy::Gedcom::Date::Actions::calendar = $self -> clean_calendar;
139 46         1225 $Genealogy::Gedcom::Date::Actions::logger = $self -> logger;
140              
141 46         1302 $self -> bnf
142             (
143             <<'END_OF_GRAMMAR'
144              
145             :default ::= action => [values]
146              
147             lexeme default = latm => 1 # Longest Acceptable Token Match.
148              
149             # Rules, in top-down order (more-or-less).
150              
151             :start ::= gedcom_date
152              
153             gedcom_date ::= date
154             | lds_ord_date
155              
156             date ::= calendar_escape calendar_date
157              
158             calendar_escape ::=
159             calendar_escape ::= calendar_name action => calendar_name # ($t1)
160             | ('@#d') calendar_name ('@') action => calendar_name # "
161             | ('@#D') calendar_name ('@') action => calendar_name # "
162              
163             calendar_date ::= gregorian_date action => gregorian_date # ($t1)
164             | julian_date action => julian_date # ($t1)
165             | french_date action => french_date # ($t1)
166             | german_date action => german_date # ($t1)
167             | hebrew_date action => hebrew_date # ($t1)
168              
169             gregorian_date ::= day gregorian_month gregorian_year
170             | gregorian_month gregorian_year
171             | gregorian_year_bce
172             | gregorian_year
173              
174             day ::= one_or_two_digits action => ::first # ($t1)
175              
176             gregorian_month ::= gregorian_month_name action => gregorian_month # ($t1)
177              
178             gregorian_year ::= number action => year # ($t1, $t2)
179             | number ('/') two_digits action => year # "
180              
181             gregorian_year_bce ::= gregorian_year bce action => gregorian_year_bce # ($t1, $t2)
182              
183             julian_date ::= day gregorian_month_name year
184             | gregorian_month_name year
185             | julian_year_bce
186             | year
187              
188             julian_year_bce ::= year bce action => julian_year_bce # ($t1, $t2)
189              
190             year ::= number action => year # ($t1, $t2)
191              
192             french_date ::= day french_month_name year
193             | french_month_name year
194             | year bce
195             | year
196              
197             german_date ::= day dot german_month_name dot german_year
198             | german_month_name dot german_year
199             | german_year
200              
201             german_year ::= year
202             | year german_bce
203              
204             hebrew_date ::= day hebrew_month_name year
205             | hebrew_month_name year
206             | year bce
207             | year
208              
209             lds_ord_date ::= date_value
210              
211             date_value ::= date_period
212             | date_range
213             | approximated_date
214             | interpreted_date action => interpreted_date # ($t1)
215             | ('(') date_phrase (')') action => date_phrase # ($t1)
216              
217             date_period ::= from_date to_date
218             | from_date
219             | to_date
220              
221             from_date ::= from date action => from_date # ($t1, $t2)
222              
223             to_date ::= to date action => to_date # ($t1, $t2)
224              
225             date_range ::= before date action => before_date # ($t1, $t2)
226             | after date action => after_date # ($t1, $t2)
227             | between date and date action => between_date # ($t1, $t2, $t3, $t4)
228              
229             approximated_date ::= about date action => about_date # ($t1, $t2)
230             | calculated date action => calculated_date # ($t1, $t2)
231             | estimated date action => estimated_date # ($t1, $t2)
232              
233             interpreted_date ::= interpreted date ('(') date_phrase (')')
234              
235             date_phrase ::= date_text
236              
237             # Lexemes, in alphabetical order.
238              
239             about ~ 'abt':i
240             | 'about':i
241             | 'circa':i
242              
243             after ~ 'aft':i
244             | 'after':i
245              
246             and ~ 'and':i
247              
248             bce ~ 'bc':i
249             | 'b.c.':i
250             | 'bce':i
251              
252             before ~ 'bef':i
253             | 'before':i
254              
255             between ~ 'bet':i
256             | 'between':i
257              
258             calculated ~ 'cal':i
259             | 'calculated':i
260              
261             calendar_name ~ 'french r':i
262             | 'frenchr':i
263             | 'german':i
264             | 'gregorian':i
265             | 'hebrew':i
266             | 'julian':i
267              
268             date_text ~ [^)\x{0a}\x{0b}\x{0c}\x{0d}]+
269              
270             digit ~ [0-9]
271              
272             dot ~ '.'
273              
274             estimated ~ 'est':i
275             | 'estimated':i
276              
277             french_month_name ~ 'vend':i | 'brum':i | 'frim':i | 'nivo':i | 'pluv':i | 'vent':i
278             | 'germ':i | 'flor':i | 'prai':i | 'mess':i | 'ther':i
279             | 'fruc':i | 'comp':i
280              
281             from ~ 'from':i
282              
283             german_bce ~ 'vc':i
284             | 'v.c.':i
285             | 'v.chr.':i
286             | 'vchr':i
287             | 'vuz':i
288             | 'v.u.z.':i
289              
290             german_month_name ~ 'jan':i | 'feb':i | 'mär':i | 'maer':i | 'mrz':i | 'apr':i | 'mai':i
291             | 'jun':i | 'jul':i | 'aug':i | 'sep':i | 'sept':i | 'okt':i
292             | 'nov':i | 'dez':i
293              
294             gregorian_month_name ~ 'jan':i | 'feb':i | 'mar':i | 'apr':i | 'may':i | 'jun':i
295             | 'jul':i | 'aug':i | 'sep':i | 'oct':i | 'nov':i | 'dec':i
296              
297             hebrew_month_name ~ 'tsh':i | 'csh':i | 'ksl':i | 'tvt':i | 'shv':i | 'adr':i
298             | 'ads':i | 'nsn':i | 'iyr':i | 'svn':i | 'tmz':i | 'aav':i | 'ell':i
299              
300             interpreted ~ 'int':i
301             | 'interpreted':i
302              
303             number ~ digit+
304              
305             one_or_two_digits ~ digit
306             | digit digit
307              
308             to ~ 'to':i
309              
310             two_digits ~ digit digit
311              
312             # Boilerplate.
313              
314             :discard ~ whitespace
315             whitespace ~ [\s]+
316              
317             END_OF_GRAMMAR
318             );
319              
320 46         1324 $self -> grammar
321             (
322             Marpa::R2::Scanless::G -> new
323             ({
324             source => \$self -> bnf
325             })
326             );
327              
328             } # End of BUILD.
329              
330             # ------------------------------------------------
331              
332             sub canonical_date
333             {
334 456     456 1 543 my($self, $result) = @_;
335 456         643 my($date) = '';
336              
337 456         389 my($separator);
338              
339 456 100 66     3779 if ($$result{type} && ($$result{type} =~ /(?:French|Gregorian|Hebrew|Julian)/) )
340             {
341 392         481 $separator = ' ';
342             }
343             else # German.
344             {
345 64         66 $separator = '.';
346             }
347              
348 456 100 66     2648 if ($$result{type} && ($$result{type} =~ /(French r|German|Hebrew|Julian)/) )
349             {
350 258         774 $date = '@#d' . "\U$1" . '@';
351             }
352              
353 456 100       1023 $date .= defined($$result{day}) ? $date ? " $$result{day}" : $$result{day} : '';
    100          
354              
355 456 100       698 if ($$result{month})
356             {
357 177 100       313 if (defined $$result{day})
358             {
359 85 50       179 $date .= $date ? "$separator$$result{month}" : $$result{month};
360             }
361             else
362             {
363 92 100       214 $date .= $date ? " $$result{month}" : $$result{month};
364             }
365              
366 177 50       360 $date .= $date ? "$separator$$result{year}" : $$result{year};
367             }
368             else
369             {
370 279 100       932 $date .= $date ? " $$result{year}" : $$result{year} if (defined $$result{year});
    100          
371             }
372              
373 456 100       892 $date .= "/$$result{suffix}" if (defined $$result{suffix});
374 456 100       834 $date .= " $$result{bce}" if ($$result{bce});
375              
376 456 100       851 if (defined $$result{phrase})
377             {
378 16 100       49 $date .= $date ? " $$result{phrase}" : $$result{phrase};
379             }
380              
381 456         1161 return $date;
382              
383             } # End of canonical_date.
384              
385             # ------------------------------------------------
386              
387             sub canonical_form
388             {
389 0     0 1 0 my($self, $result) = @_;
390 0         0 my(@date) = ('', '');
391              
392 0         0 my($separator);
393              
394 0         0 for my $i (0 .. $#$result)
395             {
396 0         0 $date[$i] = $self -> canonical_date($$result[$i]);
397 0 0       0 $date[$i] = $$result[$i]{flag} ? $date[$i] ? "$$result[$i]{flag} $date[$i]" : $$result[$i]{flag} : $date[$i];
    0          
398             }
399              
400 0 0       0 return $date[1] ? "$date[0] $date[1]" : $date[0];
401              
402             } # End of canonical_form.
403              
404             # ------------------------------------------------
405              
406             sub clean_calendar
407             {
408 3003     3003 0 2678 my($self) = @_;
409 3003         53885 my($calendar) = $self -> _calendar;
410 3003         11764 $calendar =~ s/\@\#d(.+)\@/$1/; # Zap gobbledegook if present.
411 3003         3871 $calendar = ucfirst lc $calendar;
412              
413 3003         37609 return $self -> _calendar($calendar);
414              
415             } # End of clean_calendar.
416              
417             # --------------------------------------------------
418              
419             sub compare
420             {
421 21     21 1 431 my($self, $other) = @_;
422 21         262 my($result_1) = $self -> result;
423 21 50       150 my($date_1) = $self -> normalize_date($#$result_1 < 0 ? {} : $$result_1[0]);
424 21         282 my($result_2) = $other -> result;
425 21 50       129 my($date_2) = $self -> normalize_date($#$result_2 < 0 ? {} : $$result_2[0]);
426              
427             # Return:
428             # o 0 if the dates have different date escapes.
429             # o 1 if $date_1 < $date_2.
430             # o 2 if $date_1 = $date_2.
431             # o 3 if $date_1 > $date_2.
432              
433 21         24 my($result);
434              
435 21 100 66     204 if ( ($$date_1{kind} ne $$date_2{kind}) || ($$date_1{type} ne $$date_2{type}) )
    100 100        
    100 66        
436             {
437 3         6 $result = 0;
438             }
439             elsif ($$date_1{bce} && ($$date_2{bce} eq '') )
440             {
441             # We don't care what the value of 'bce' is. We only care if it has been set or not.
442              
443 1         1 $result = 1;
444             }
445             elsif ( ($$date_1{bce} eq '') && $$date_2{bce})
446             {
447 1         2 $result = 3;
448             }
449             else
450             {
451 16         27 my($format) = '%4d-%4s-%02d';
452 16         134 my($form_1) = sprintf($format, $$date_1{year}, $$date_1{month}, $$date_1{day});
453 16         45 my($form_2) = sprintf($format, $$date_2{year}, $$date_2{month}, $$date_2{day});
454              
455 16 100       67 if ($form_1 eq $form_2)
    100          
    100          
456             {
457 1         2 $result = 2;
458             }
459             elsif ($$date_1{bce})
460             {
461             # Ahhhggg. BCE! Reverse sense of test.
462              
463 1 50       4 if ($form_1 lt $form_2)
464             {
465 1         3 $result = 3;
466             }
467             else
468             {
469 0         0 $result = 1;
470             }
471             }
472             elsif ($form_1 lt $form_2)
473             {
474 9         17 $result = 1;
475             }
476             else
477             {
478 5         11 $result = 3;
479             }
480             }
481              
482 21         43 return $result;
483              
484             } # End of compare.
485              
486             # ------------------------------------------------
487              
488             sub decode_result
489             {
490 1791     1791 0 1913 my($self, $result) = @_;
491 1791         2198 my(@worklist) = $result;
492              
493 1791         1344 my($obj);
494             my($ref_type);
495 0         0 my(@stack);
496              
497             do
498 1791         1330 {
499 12524         8399 $obj = shift @worklist;
500 12524         9243 $ref_type = ref $obj;
501              
502 12524 100       14160 if ($ref_type eq 'ARRAY')
    50          
    0          
503             {
504 7546         12374 unshift @worklist, @$obj;
505             }
506             elsif ($ref_type eq 'HASH')
507             {
508 4978         17654 push @stack, {%$obj};
509             }
510             elsif ($ref_type)
511             {
512 0         0 die "Unsupported object type $ref_type\n";
513             }
514             else
515             {
516 0         0 push @stack, $obj;
517             }
518              
519             } while (@worklist);
520              
521 1791         3699 return [@stack];
522              
523             } # End of decode_result.
524              
525             # ------------------------------------------------
526              
527             sub log
528             {
529 397     397 1 200534 my($self, $level, $s) = @_;
530              
531 397 50       7666 $self -> logger -> log($level => $s) if ($self -> logger);
532              
533             } # End of log.
534              
535             # ------------------------------------------------
536              
537             sub normalize_date
538             {
539 42     42 1 70 my($self, $date) = @_;
540 42 100       110 $$date{bce} = '' if (! defined $$date{bce});
541 42 100 66     132 $$date{day} = 0 if (! defined $$date{day} || ($$date{day} !~ /^\d+$/) );
542 42 50       67 $$date{kind} = '' if (! defined $$date{kind});
543 42 100       94 $$date{month} = '' if (! defined $$date{month});
544 42 50       66 $$date{type} = '' if (! defined $$date{type});
545 42 50       66 $$date{year} = 0 if (! defined $$date{year});
546 42         72 my($index) = index($$date{year}, '/');
547 42 50       65 $$date{year} = substr($$date{year}, 0, $index - 1) if ($index >= 0);
548              
549 42         64 return $date;
550              
551             } # End of normalize_date.
552              
553             # --------------------------------------------------
554              
555             sub parse
556             {
557 397     397 1 5163697 my($self, %args) = @_;
558 397 50       8780 my($canonical) = defined($args{canonical}) ? $args{canonical} : $self -> canonical;
559 397 50       2279 $canonical = $canonical < 0 ? 0 : $canonical > 2 ? 2 : $canonical;
    50          
560 397 50       974 my($date) = defined($args{date}) ? $args{date} : $self -> date;
561 397 50       917 $date = '' if (! defined $date);
562              
563             # Now we have the date, zap any commas outside any ().
564              
565 397         1712 my(@chars) = split(//, $date);
566 397         472 my($i) = 0;
567 397 50       854 my($finished) = $#chars < $i ? 1 : 0;
568              
569 397         812 while (! $finished)
570             {
571 7549 100 100     16897 if ( ($i > $#chars) || ($chars[$i] eq '(') )
572             {
573 397         697 $finished = 1;
574             }
575             else
576             {
577 7152 100       7925 $chars[$i] = ' ' if ($chars[$i] eq ',');
578              
579 7152         7986 $i++;
580             }
581             }
582              
583 397         1067 $date = join('', @chars);
584              
585 397         6010 $self -> canonical($canonical);
586 397         12984 $self -> date($date);
587 397         10872 $self -> error('');
588 397         10089 $self -> recce
589             (
590             Marpa::R2::Scanless::R -> new
591             ({
592             grammar => $self -> grammar,
593             ranking_method => 'high_rule_only',
594             semantics_package => 'Genealogy::Gedcom::Date::Actions',
595             })
596             );
597              
598 397         102544 my($result) = [];
599              
600 397 50       1129 if (length($date) == 0)
601             {
602 0         0 $self -> error('Input is the empty string');
603              
604 0         0 return $result;
605             }
606              
607             try
608             {
609 397     397   18870 $self -> recce -> read(\$date);
610              
611 397         131288 my($ambiguity_metric) = $self -> recce -> ambiguity_metric;
612              
613 397 50       19391 if ($ambiguity_metric <= 0)
    100          
614             {
615 0         0 my($line, $column) = $self -> recce -> line_column();
616 0         0 my($whole_length) = length $date;
617 0         0 my($suffix) = substr($date, ($whole_length - 100) );
618 0         0 my($suffix_length) = length $suffix;
619 0 0       0 my($s) = $suffix_length == 1 ? 'char' : "$suffix_length chars";
620 0         0 my($message) = "Call to ambiguity_metric() returned $ambiguity_metric (i.e. an error). \n"
621             . "Marpa exited at (line, column) = ($line, $column) within the input string. \n"
622             . "Input length: $whole_length. Last $s of input: '$suffix'";
623              
624 0         0 $self -> error($message);
625              
626 0         0 $self -> log(error => "Parse failed. $message");
627             }
628             elsif ($ambiguity_metric == 1)
629             {
630 161         383 $result = $self -> process_unambiguous();
631             }
632             else
633             {
634 236         581 $result = $self -> process_ambiguous();
635             }
636             }
637             catch
638             {
639 0     0   0 my($error) = $_;
640              
641 0         0 $self -> error($error);
642 0         0 $self -> log(debug => $self -> error);
643 397         3536 };
644              
645 397         7868 for my $i (0 .. $#$result)
646             {
647 456         1268 $$result[$i]{canonical} = $self -> canonical_date($$result[$i]);
648             }
649              
650 397 50       7735 if ($self -> canonical == 0)
    0          
651             {
652 397         2739 $self -> log(debug => "Return value from parse(): \n" . Dumper($result) );
653             }
654             elsif ($self -> canonical == 1)
655             {
656 0         0 $self -> log(debug => $self -> canonical_form($result) );
657             }
658             else
659             {
660 0         0 $self -> log(debug => $self -> canonical_date($$result[$_]) ) for (0 .. $#$result);
661             }
662              
663 397 50 33     21639 $self -> error("Unable to parse '" . $self -> date . "'") if ( (! $self -> error) && $#$result < 0);
664 397         8183 $self -> result($result);
665              
666 397         7942 return $result;
667              
668             } # End of parse.
669              
670             # --------------------------------------------------
671              
672             sub process_ambiguous
673             {
674 236     236 0 290 my($self) = @_;
675 236         501 my($calendar) = $self -> clean_calendar;
676 236         4356 my(%count) =
677             (
678             AND => 0,
679             BET => 0,
680             FROM => 0,
681             TO => 0,
682             );
683 236         313 my($result) = [];
684              
685 236         227 my($item);
686              
687 236         3282 while (my $value = $self -> recce -> value)
688             {
689 1630         48984 $value = $self -> decode_result($$value);
690              
691 1630         2083 for $item (@$value)
692             {
693 4722 100       19905 if ($$item{kind} eq 'Calendar')
694             {
695 2162         2029 $calendar = $$item{type};
696              
697 2162         2212 next;
698             }
699              
700 2560 100       3789 if ($calendar eq $$item{type})
701             {
702             # We have to allow for the fact that when 'From .. To' or 'Between ... And'
703             # are used, both dates are ambiguous, and we end up with double the number
704             # of elements in the arrayref compared to what's expected.
705              
706 638 100 100     2642 if (exists $$item{flag} && exists $count{$$item{flag} })
707             {
708 489 100       1048 if ($count{$$item{flag} } == 0)
709             {
710 141         157 $count{$$item{flag} }++;
711              
712 141         189 push @$result, $item;
713             }
714             }
715             else
716             {
717 149         216 push @$result, $item;
718             }
719             }
720              
721             # Sometimes we must reverse the array elements.
722              
723 2560 100       3976 if ($#$result == 1)
724             {
725 1352 100 66     4849 if ( ($$result[0]{flag} eq 'AND') && ($$result[1]{flag} eq 'BET') )
    100 66        
726             {
727 12         26 ($$result[0], $$result[1]) = ($$result[1], $$result[0]);
728             }
729             elsif ( ($$result[0]{flag} eq 'TO') && ($$result[1]{flag} eq 'FROM') )
730             {
731 2         5 ($$result[0], $$result[1]) = ($$result[1], $$result[0]);
732             }
733             }
734              
735             # Reset the calendar. Note: The 'next' above skips this statement.
736              
737 2560         4306 $calendar = $self -> clean_calendar;
738             }
739             }
740              
741 236         15250 return $result;
742              
743             } # End of process_ambiguous.
744              
745             # --------------------------------------------------
746              
747             sub process_unambiguous
748             {
749 161     161 0 177 my($self) = @_;
750 161         321 my($calendar) = $self -> clean_calendar;
751 161         2895 my($result) = [];
752 161         2205 my($value) = $self -> recce -> value;
753 161         4906 $value = $self -> decode_result($$value);
754              
755 161 100 33     823 if ($#$value == 0)
    50          
    100          
    100          
    50          
756             {
757 74         112 $value = $$value[0];
758              
759 74 100       686 if ($$value{type} =~ /^(?:$calendar|Phrase)$/)
760             {
761 18         44 $$result[0] = $value;
762             }
763             else
764             {
765 56         111 $result = [$value];
766             }
767             }
768             elsif ($#$value == 2)
769             {
770 0         0 $result = [$$value[0], $$value[1] ];
771             }
772             elsif ($#$value == 3)
773             {
774 4         10 $result = [$$value[1], $$value[3] ];
775             }
776             elsif ($$value[0]{kind} eq 'Calendar')
777             {
778 82         117 $calendar = $$value[0]{type};
779              
780 82 50       188 if ($calendar eq $$value[1]{type})
781             {
782 82         132 $result = [$$value[1] ];
783             }
784             }
785             elsif ( ($$value[0]{type} eq $calendar) && ($$value[1]{type} eq $calendar) )
786             {
787 1         3 $result = $value;
788             }
789              
790 161         522 return $result;
791              
792             } # End of process_unambiguous.
793              
794             # --------------------------------------------------
795              
796             1;
797              
798             =pod
799              
800             =encoding utf8
801              
802             =head1 NAME
803              
804             Genealogy::Gedcom::Date - Parse GEDCOM dates in French r/German/Gregorian/Hebrew/Julian
805              
806             =head1 Synopsis
807              
808             A script (scripts/synopsis.pl):
809              
810             #!/usr/bin/env perl
811              
812             use strict;
813             use warnings;
814              
815             use Genealogy::Gedcom::Date;
816              
817             # --------------------------
818              
819             sub process
820             {
821             my($count, $parser, $date) = @_;
822              
823             print "$count: $date: ";
824              
825             my($result) = $parser -> parse(date => $date);
826              
827             print "Canonical date @{[$_ + 1]}: ", $parser -> canonical_date($$result[$_]), ". \n" for (0 .. $#$result);
828             print 'Canonical form: ', $parser -> canonical_form($result), ". \n";
829             print "\n";
830              
831             } # End of process.
832              
833             # --------------------------
834              
835             my($parser) = Genealogy::Gedcom::Date -> new(maxlevel => 'debug');
836              
837             process(1, $parser, 'Julian 1950');
838             process(2, $parser, '@#dJulian@ 1951');
839             process(3, $parser, 'From @#dJulian@ 1952 to Gregorian 1953/54');
840             process(4, $parser, 'From @#dFrench r@ 1955 to 1956');
841             process(5, $parser, 'From @#dJulian@ 1957 to German 1.Dez.1958');
842              
843             One-liners:
844              
845             perl scripts/parse.pl -max debug -d 'Between Gregorian 1701/02 And Julian 1703'
846              
847             Output:
848              
849             Return value from parse():
850             [
851             {
852             canonical => "1701/02",
853             flag => "BET",
854             kind => "Date",
855             suffix => "02",
856             type => "Gregorian",
857             year => 1701
858             },
859             {
860             canonical => "\@#dJULIAN\@ 1703",
861             flag => "AND",
862             kind => "Date",
863             type => "Julian",
864             year => 1703
865             }
866             ]
867              
868             perl scripts/parse.pl -max debug -d 'Int 10 Nov 1200 (Approx)'
869              
870             Output:
871              
872             [
873             {
874             canonical => "10 Nov 1200 (Approx)",
875             day => 10,
876             flag => "INT",
877             kind => "Date",
878             month => "Nov",
879             phrase => "(Approx)",
880             type => "Gregorian",
881             year => 1200
882             }
883             ]
884              
885             perl scripts/parse.pl -max debug -d '(Unknown)'
886              
887             Output:
888              
889             Return value from parse():
890             [
891             {
892             canonical => "(Unknown)",
893             kind => "Phrase",
894             phrase => "(Unknown)",
895             type => "Phrase"
896             }
897             ]
898              
899             See the L for the explanation of the output arrayrefs.
900              
901             See also scripts/parse.pl and scripts/compare.pl for sample code.
902              
903             Lastly, you are I encouraged to peruse t/*.t.
904              
905             =head1 Description
906              
907             L provides a L-based parser for GEDCOM dates.
908              
909             Calender escapes supported are (case-insensitive): French r/German/Gregorian/Hebrew/Julian.
910              
911             Gregorian is the default, and does not need to be used at all.
912              
913             Comparison of 2 C-based objects is supported by calling the sub
914             L method on one object and passing the other object as the parameter.
915              
916             Note: C can return any one of four (4) values.
917              
918             See L, p 45.
919              
920             =head1 Installation
921              
922             Install L as you would for any C module:
923              
924             Run:
925              
926             cpanm Genealogy::Gedcom::Date
927              
928             or run:
929              
930             sudo cpan Genealogy::Gedcom::Date
931              
932             or unpack the distro, and then either:
933              
934             perl Build.PL
935             ./Build
936             ./Build test
937             sudo ./Build install
938              
939             or:
940              
941             perl Makefile.PL
942             make (or dmake or nmake)
943             make test
944             make install
945              
946             =head1 Constructor and Initialization
947              
948             C is called as C<< my($parser) = Genealogy::Gedcom::Date -> new(k1 => v1, k2 => v2, ...) >>.
949              
950             It returns a new object of type C.
951              
952             Key-value pairs accepted in the parameter list (see corresponding methods for details
953             [e.g. L]):
954              
955             =over 4
956              
957             =item o canonical => $integer
958              
959             Note: Nothing is printed unless C is set to C.
960              
961             =over 4
962              
963             =item o canonical => 0
964              
965             Data::Dumper::Concise's Dumper() prints the output of the parse.
966              
967             =item o canonical => 1
968              
969             canonical_form() is called on the output of parse() to print a string.
970              
971             =item o canonical => 2
972              
973             canonocal_date() is called on each element in the result from parse(), to print strings on
974             separate lines.
975              
976             =back
977              
978             Default: 0.
979              
980             =item o date => $date
981              
982             The string to be parsed.
983              
984             Each ',' is replaced by a space. See the L for details.
985              
986             Default: ''.
987              
988             =item o logger => $aLoggerObject
989              
990             Specify a logger compatible with L, for the lexer and parser to use.
991              
992             Default: A logger of type L which writes to the screen.
993              
994             To disable logging, just set 'logger' to the empty string (not undef).
995              
996             =item o maxlevel => $logOption1
997              
998             This option affects L.
999              
1000             See the L docs.
1001              
1002             By default nothing is printed.
1003              
1004             Typical values are: 'error', 'notice', 'info' and 'debug'.
1005              
1006             The default produces no output.
1007              
1008             Default: 'notice'.
1009              
1010             =item o minlevel => $logOption2
1011              
1012             This option affects L.
1013              
1014             See the L docs.
1015              
1016             Default: 'error'.
1017              
1018             No lower levels are used.
1019              
1020             =back
1021              
1022             Note: The parameters C and C can also be passed to L.
1023              
1024             =head1 Methods
1025              
1026             =head2 canonical([$integer])
1027              
1028             Here, the [] indicate an optional parameter.
1029              
1030             Gets or sets the C option, which controls what exactly L prints when
1031             L is set to C.
1032              
1033             By default nothing is printed.
1034              
1035             See L, next, for sample code.
1036              
1037             =head2 canonical_date($hashref)
1038              
1039             $hashref is either element of the arrayref returned by L. The hashref may be
1040             empty.
1041              
1042             Returns a date string (or the empty string) normalized in various ways:
1043              
1044             =over 4
1045              
1046             =item o If Gregorian (in any form) was in the original string, it is discarded
1047              
1048             This is done because it's the default.
1049              
1050             =item o If any other calendar escape was in the original string, it is preserved
1051              
1052             And it's output in all caps.
1053              
1054             And as a special case, 'FRENCHR' is returned as 'FRENCH R'.
1055              
1056             =item o If About, etc were in the orginal string, they are discarded
1057              
1058             This means the C key in the hashref is ignored.
1059              
1060             =back
1061              
1062             Note: This method is called by L to populate the C key in the arrayref
1063             of hashrefs returned by C.
1064              
1065             Try:
1066              
1067             perl scripts/parse.pl -max debug -d 'From 21 Jun 1950 to @#dGerman@ 05.Mär.2015'
1068              
1069             perl scripts/parse.pl -max debug -d 'From 21 Jun 1950 to @#dGerman@ 05.Mär.2015' -c 0
1070              
1071             perl scripts/parse.pl -max debug -d 'From 21 Jun 1950 to @#dGerman@ 05.Mär.2015' -c 1
1072              
1073             perl scripts/parse.pl -max debug -d 'From 21 Jun 1950 to @#dGerman@ 05.Mär.2015' -c 2
1074              
1075             =head2 canonical_form($arrayref)
1076              
1077             Returns a date string containing zero, one or two dates.
1078              
1079             This method calls L for each element in the $arrayref. The arrayref
1080             may be empty.
1081              
1082             Then it adds information from the C key in each element, if present.
1083              
1084             For sample code, see L just above.
1085              
1086             =head2 compare($other_object)
1087              
1088             Returns an integer 0 .. 3 (sic) indicating the temporal relationship between the invoking object
1089             ($self) and $other_object.
1090              
1091             Returns one of these values:
1092              
1093             0 if the dates have different date escapes.
1094             1 if $date_1 < $date_2.
1095             2 if $date_1 = $date_2.
1096             3 if $date_1 > $date_2.
1097              
1098             Note: Gregorian years like 1510/02 are converted into 1510 before the dates are compared. Create a
1099             sub-class and override L if desired.
1100              
1101             See scripts/compare.pl for sample code.
1102              
1103             See also L.
1104              
1105             =head2 date([$date])
1106              
1107             Here, [ and ] indicate an optional parameter.
1108              
1109             Gets or sets the date to be parsed.
1110              
1111             The date in C<< parse(date => $date) >> takes precedence over both C<< new(date => $date) >>
1112             and C.
1113              
1114             This means if you call C as C<< parse(date => $date) >>, then the value C<$date> is stored
1115             so that if you subsequently call C, that value is returned.
1116              
1117             Note: C is a parameter to new().
1118              
1119             =head2 error()
1120              
1121             Gets the last error message.
1122              
1123             Returns '' (the empty string) if there have been no errors.
1124              
1125             If L throws an exception, it is caught by a try/catch block, and the C error
1126             is returned by this method.
1127              
1128             See L for more about C.
1129              
1130             =head2 log($level, $s)
1131              
1132             If a logger is defined, this logs the message $s at level $level.
1133              
1134             =head2 logger([$logger_object])
1135              
1136             Here, the [] indicate an optional parameter.
1137              
1138             Get or set the logger object.
1139              
1140             To disable logging, just set 'logger' to the empty string (not undef), in the call to L.
1141              
1142             This logger is passed to other modules.
1143              
1144             'logger' is a parameter to L. See L for details.
1145              
1146             =head2 maxlevel([$string])
1147              
1148             Here, the [] indicate an optional parameter.
1149              
1150             Get or set the value used by the logger object.
1151              
1152             This option is only used if an object of type L is ceated.
1153             See L.
1154              
1155             Typical values are: 'notice', 'info' and 'debug'. The default, 'notice', produces no output.
1156              
1157             The code emits a message with log level 'error' if Marpa throws an exception, and it displays
1158             the result of the parse at level 'debug' if maxlevel is set that high. The latter display uses
1159             L's function C.
1160              
1161             'maxlevel' is a parameter to L. See L for details.
1162              
1163             =head2 minlevel([$string])
1164              
1165             Here, the [] indicate an optional parameter.
1166              
1167             Get or set the value used by the logger object.
1168              
1169             This option is only used if an object of type L is created.
1170             See L.
1171              
1172             'minlevel' is a parameter to L. See L for details.
1173              
1174             =head2 new([%args])
1175              
1176             The constructor. See L.
1177              
1178             =head2 normalize_date($date_hash)
1179              
1180             Normalizes $date_hash for each date during a call to L.
1181              
1182             Override in a sub-class if you wish to change the normalization technique.
1183              
1184             =head2 parse([%args])
1185              
1186             Here, [ and ] indicate an optional parameter.
1187              
1188             C returns an arrayref. See the L for details.
1189              
1190             If the arrayref is empty, call L to retrieve the error message.
1191              
1192             In particular, the arrayref will be empty if the input date is the empty string.
1193              
1194             C takes the same parameters as C.
1195              
1196             Warning: The array can contain 1 element when 2 are expected. This can happen if your input contains
1197             'From ... To ...' or 'Between ... And ...', and one of the dates is invalid. That is, the return
1198             value from C will contain the valid date but no indicator of the invalid one.
1199              
1200             =head1 Extensions to the Gedcom specification
1201              
1202             This chapter lists exactly how this code differs from the Gedcom spec.
1203              
1204             =over 4
1205              
1206             =item o Input may be in Unicode
1207              
1208             =item o Input may be in any case
1209              
1210             =item o Input may omit calendar escapes when the date is unambigous
1211              
1212             =item o Any of the following tokens may be used
1213              
1214             =over 4
1215              
1216             =item o abt, about, circa
1217              
1218             =item o aft, after
1219              
1220             =item o and
1221              
1222             =item o bc, b.c., bce
1223              
1224             =item o bef, before
1225              
1226             =item o bet, between
1227              
1228             =item o cal, calculated
1229              
1230             =item o french r, frenchr, german, gregorian, hebrew, julian,
1231              
1232             =item o est, estimated
1233              
1234             =item o from
1235              
1236             =item o German BCE
1237              
1238             vc, v.c., v.chr., vchr, vuz, v.u.z.
1239              
1240             =item o German month names
1241              
1242             jan, feb, mär, maer, mrz, apr, mai, jun, jul, aug, sep, sept, okt, nov, dez
1243              
1244             =item o Gregorian month names
1245              
1246             jan, feb, mar, apr, may, jun, jul, aug, sep, oct, nov, dec
1247              
1248             =item o Hebrew month names
1249              
1250             tsh, csh, ksl, tvt, shv, adr, ads, nsn, iyr, svn, tmz, aav, ell
1251              
1252             =item o int, interpreted
1253              
1254             =item o to
1255              
1256             =back
1257              
1258             =back
1259              
1260             =head1 FAQ
1261              
1262             =head2 What is the format of the value returned by parse()?
1263              
1264             It is always an arrayref.
1265              
1266             If the date is like '1950' or 'Bef 1950 BCE', there will be 1 element in the arrayref.
1267              
1268             If the date contains both 'From' and 'To', or both 'Between' and 'And', then the arrayref will
1269             contain 2 elements.
1270              
1271             Each element is a hashref, with various combinations of the following keys. You need to check the
1272             existence of some keys before processing the date.
1273              
1274             This means missing values (day, month, bce) are never fabricated. These keys only appear in the
1275             hashref if such a token was found in the input.
1276              
1277             Keys:
1278              
1279             =over 4
1280              
1281             =item o bce
1282              
1283             If the input contains any (case-insensitive) BCE indicator, under any calendar escape, the C
1284             key will hold the exact indicator.
1285              
1286             =item o canonical => $string
1287              
1288             L calls L to populate this key.
1289              
1290             =item o day => $integer
1291              
1292             If the input contains a day, then the C key will be present.
1293              
1294             =item o flag => $string
1295              
1296             If the input contains any of the following (case-insensitive), then the C key will be present:
1297              
1298             =over 4
1299              
1300             =item o Abt or About
1301              
1302             =item o Aft or After
1303              
1304             =item o And
1305              
1306             =item o Bef or Before
1307              
1308             =item o Bet or Between
1309              
1310             =item o Cal or Calculated
1311              
1312             =item o Est or Estimated
1313              
1314             =item o From
1315              
1316             =item o Int or Interpreted
1317              
1318             =item o To
1319              
1320             =back
1321              
1322             $string will take one of these values (case-sensitive):
1323              
1324             =over 4
1325              
1326             =item o ABT
1327              
1328             =item o AFT
1329              
1330             =item o AND
1331              
1332             =item o BEF
1333              
1334             =item o BET
1335              
1336             =item o CAL
1337              
1338             =item o EST
1339              
1340             =item o FROM
1341              
1342             =item o INT
1343              
1344             =item o TO
1345              
1346             =back
1347              
1348             =item o kind => 'Date' or 'Phrase'
1349              
1350             The C key is always present, and always takes the value 'Date' or 'Phrase'.
1351              
1352             If the value is 'Phrase', see the C and C keys.
1353              
1354             During processing, there can be another - undocumented - element in the arrayref. It represents
1355             the calendar escape, and in that case C takes the value 'Calendar'. This element is discarded
1356             before the final arrayref is returned to the caller.
1357              
1358             =item o month => $string
1359              
1360             If the input contains a month, then the C key will be present. The case of $string will be
1361             exactly whatever was in the input.
1362              
1363             =item o phrase => "($string)"
1364              
1365             If the input contains a date phrase, then the C key will be present. The case of $string
1366             will be exactly whatever was in the input.
1367              
1368             parse(date => 'Int 10 Nov 1200 (Approx)') returns:
1369              
1370             [
1371             {
1372             day => 10,
1373             flag => "INT",
1374             kind => "Date",
1375             month => "Nov",
1376             phrase => "(Approx)",
1377             type => "Gregorian",
1378             year => 1200
1379             }
1380             ]
1381              
1382             parse(date => '(Unknown)') returns:
1383              
1384             [
1385             {
1386             kind => "Phrase",
1387             phrase => "(Unknown)",
1388             type => "Phrase"
1389             }
1390             ]
1391              
1392             See also the C and C keys.
1393              
1394             =item o suffix => $two_digits
1395              
1396             If the year contains a suffix (/00), then the C key will be present. The '/' is
1397             discarded.
1398              
1399             Obviously, this key can only appear when the year is of the Gregorian form 1700/00.
1400              
1401             See also the C key below.
1402              
1403             =item o type => $string
1404              
1405             The C key is always present, and takes one of these case-sensitive values:
1406              
1407             =over 4
1408              
1409             =item o 'French r'
1410              
1411             =item o German
1412              
1413             =item o Gregorian
1414              
1415             =item o Hebrew
1416              
1417             =item o Julian
1418              
1419             =item o Phrase
1420              
1421             See also the C and C keys.
1422              
1423             =back
1424              
1425             =item o year => $integer
1426              
1427             If the input contains a year, then the C key is present.
1428              
1429             If the year contains a suffix (/00), see also the C key, above. This means the value of
1430             the C key is never "$integer/$two_digits".
1431              
1432             =back
1433              
1434             =head2 When should I use a calendar escape?
1435              
1436             =over 4
1437              
1438             =item o In theory, for every non-Gregorian date
1439              
1440             In practice, if the month name is unique to a specific language, then the escape is not needed,
1441             since L and this code automatically handle ambiguity.
1442              
1443             Likewise, if you use a Gregorian year in the form 1700/01, then the calendar escape is obvious.
1444              
1445             The escape is, of course, always inserted into the values returned by the C pair of
1446             methods when they process non-Gregorian dates. That makes their output compatible with
1447             other software. And no matter what case you use specifying the calendar escape, it is always
1448             output in upper-case.
1449              
1450             =item o When you wish to force the code to provide an unambiguous result
1451              
1452             All Gregorian and Julian dates are ambiguous, unless they use the year format 1700/01.
1453              
1454             So, to resolve the ambiguity, add the calendar escape.
1455              
1456             =back
1457              
1458             =head2 Why is '@' escaped with '\' when L's C prints things?
1459              
1460             That's just how that module handles '@'.
1461              
1462             =head2 Does this module accept Unicode?
1463              
1464             Yes.
1465              
1466             See t/German.t for sample code.
1467              
1468             =head2 Can I change the default calendar?
1469              
1470             No. It is always Gregorian.
1471              
1472             =head2 Are dates massaged before being processed?
1473              
1474             Yes. Commas are replaced by spaces.
1475              
1476             =head2 French month names
1477              
1478             See L.
1479              
1480             =head2 German month names
1481              
1482             See L.
1483              
1484             =head2 Hebrew month names
1485              
1486             See L.
1487              
1488             =head2 What happens if C is given a string like 'To 2000 From 1999'?
1489              
1490             The code I reorder the dates.
1491              
1492             =head2 Why was this module renamed from DateTime::Format::Gedcom?
1493              
1494             The L suite of modules aren't designed, IMHO, for GEDCOM-like applications. It was a
1495             mistake to use that name in the first place.
1496              
1497             By releasing under the Genealogy::Gedcom::* namespace, I can be much more targeted in the data
1498             types I choose as method return values.
1499              
1500             =head2 Why did you choose Moo over Moose?
1501              
1502             My policy is to use the lightweight L for all modules and applications.
1503              
1504             =head1 Trouble-shooting
1505              
1506             Things to consider:
1507              
1508             =over 4
1509              
1510             =item o Error message: Marpa exited at (line, column) = ($line, $column) within the input string
1511              
1512             Consider the possibility that the parse ends without a C parse, but the input is the
1513             prefix of some input that C lead to a successful parse.
1514              
1515             Marpa is not reporting a problem during the read(), because you can add more to the input string,
1516             and Marpa does not know that you do not plan to do this.
1517              
1518             =item o You tried to enter the German month name 'Mär' via the shell
1519              
1520             Read more about this by running 'perl scripts/parse.pl -h', where it discusses '-d'.
1521              
1522             =item o You mistyped the calendar escape
1523              
1524             Check: Are any of these valid?
1525              
1526             =over 4
1527              
1528             =item o @#FRENCH@
1529              
1530             =item o @#JULIAN@
1531              
1532             =item o @#djulian
1533              
1534             =item o @#juliand
1535              
1536             =item o @#djuliand
1537              
1538             =item o @#dJulian@
1539              
1540             =item o Julian
1541              
1542             =item o @#dJULIAN@
1543              
1544             =back
1545              
1546             Yes, the last 3 are accepted by this module, and the last one is accepted by other software.
1547              
1548             =item o The date is in American format (month day year)
1549              
1550             =item o You used a Julian calendar with a Gregorian year
1551              
1552             Dates - such as 1900/01 - which do not fit the Gedcom definition of a Julian year, are filtered
1553             out.
1554              
1555             =back
1556              
1557             =head1 See Also
1558              
1559             L.
1560              
1561             L
1562              
1563             L
1564              
1565             L
1566              
1567             L
1568              
1569             L is in Perl core. See L
1570              
1571             L is more sophisticated than L
1572              
1573             L implements L
1574              
1575             L
1576              
1577             L
1578              
1579             L
1580              
1581             =head1 Machine-Readable Change Log
1582              
1583             The file Changes was converted into Changelog.ini by L.
1584              
1585             =head1 Version Numbers
1586              
1587             Version numbers < 1.00 represent development versions. From 1.00 up, they are production versions.
1588              
1589             =head1 Repository
1590              
1591             L.
1592              
1593             =head1 Support
1594              
1595             Email the author, or log a bug on RT:
1596              
1597             L.
1598              
1599             =head1 Credits
1600              
1601             Thanx to Eugene van der Pijll, the author of the Gedcom::Date::* modules.
1602              
1603             Thanx also to the authors of the DateTime::* family of modules. See
1604             L for details.
1605              
1606             Thanx for Mike Elston on the perl-gedcom mailing list for providing French month abbreviations,
1607             amongst other information pertaining to the French language.
1608              
1609             Thanx to Michael Ionescu on the perl-gedcom mailing list for providing the grammar for German dates
1610             and German month abbreviations.
1611              
1612             =head1 Author
1613              
1614             L was written by Ron Savage Iron@savage.net.auE> in 2011.
1615              
1616             Homepage: L.
1617              
1618             =head1 Copyright
1619              
1620             Australian copyright (c) 2011, Ron Savage.
1621              
1622             All Programs of mine are 'OSI Certified Open Source Software';
1623             you can redistribute them and/or modify them under the terms of
1624             The Perl License, a copy of which is available at:
1625             http://dev.perl.org/licenses/
1626              
1627             =cut