File Coverage

blib/lib/DateTime/Format/Genealogy.pm
Criterion Covered Total %
statement 82 92 89.1
branch 45 58 77.5
condition 12 21 57.1
subroutine 10 10 100.0
pod 2 2 100.0
total 151 183 82.5


line stmt bran cond sub pod time code
1             package DateTime::Format::Genealogy;
2              
3             # Author Nigel Horne: njh@bandsman.co.uk
4             # Copyright (C) 2018-2020, Nigel Horne
5              
6             # Usage is subject to licence terms.
7             # The licence terms of this software are as follows:
8             # Personal single user, single computer use: GPL2
9             # All other users (including Commercial, Charity, Educational, Government)
10             # must apply in writing for a licence for use from Nigel Horne at the
11             # above e-mail.
12              
13 3     3   473928 use strict;
  3         25  
  3         90  
14 3     3   16 use warnings;
  3         6  
  3         82  
15             # use diagnostics;
16             # use warnings::unused;
17 3     3   55 use 5.006_001;
  3         11  
18              
19 3     3   1626 use namespace::clean;
  3         49452  
  3         22  
20 3     3   667 use Carp;
  3         9  
  3         159  
21 3     3   1743 use DateTime::Format::Natural;
  3         1599457  
  3         241  
22 3     3   1816 use Genealogy::Gedcom::Date 2.01;
  3         800053  
  3         37  
23              
24             our %months = (
25             'January' => 'Jan',
26             'February' => 'Feb',
27             'March' => 'Mar',
28             'April' => 'Apr',
29             # 'May' => 'May',
30             'June' => 'Jun',
31             'July' => 'Jul',
32             'August' => 'Aug',
33             'September' => 'Sep',
34             'October' => 'Oct',
35             'November' => 'Nov',
36             'December' => 'Dec'
37             );
38              
39             =head1 NAME
40              
41             DateTime::Format::Genealogy - Create a DateTime object from a Genealogy Date
42              
43             =head1 VERSION
44              
45             Version 0.03
46              
47             =cut
48              
49             our $VERSION = '0.03';
50              
51             =head1 SYNOPSIS
52              
53             =head1 SUBROUTINES/METHODS
54              
55             =head2 new
56              
57             Creates a DateTime::Format::Genealogy object.
58              
59             =cut
60              
61             sub new {
62 11     11 1 4177 my $proto = shift;
63 11   33     72 my $class = ref($proto) || $proto;
64              
65 11 50       38 return unless(defined($class));
66              
67 11         54 return bless {}, $class;
68             }
69              
70             =head2 parse_datetime($string)
71              
72             Given a date,
73             runs it through L<Genealogy::Gedcom::Date> to create a L<DateTime> object.
74             If a date range is given, return a two element array in array context, or undef in scalar context
75              
76             Returns undef if the date can't be parsed, is just a year or if it is an appoximate date starting with "c", "ca" or "abt".
77             Can be called as a class or object method.
78              
79             date: the date to be parsed
80             quiet: set to fail silently if there is an error with the date
81             strict: more strictly enforce the Gedcom standard, for example don't allow long month names
82              
83             =cut
84              
85             sub parse_datetime {
86 36     36 1 345693 my $self = shift;
87 36         77 my %params;
88              
89 36 100 100     301 if(!ref($self)) {
    100          
    100          
    100          
    100          
90 8 100       36 if(scalar(@_)) {
91 5         26 return(__PACKAGE__->new()->parse_datetime(@_));
92             }
93 3         18 return(__PACKAGE__->new()->parse_datetime($self));
94             } elsif(ref($self) eq 'HASH') {
95 1         15 return(__PACKAGE__->new()->parse_datetime($self));
96             } elsif(ref($_[0]) eq 'HASH') {
97 6         16 %params = %{$_[0]};
  6         27  
98             } elsif(ref($_[0])) {
99 1         4 Carp::croak('Usage: ', __PACKAGE__, '::parse_datetime(date => $date)');
100             } elsif(scalar(@_) && (scalar(@_) % 2 == 0)) {
101 6         25 %params = @_;
102             } else {
103 14         46 $params{'date'} = shift;
104             }
105 26         63 my $quiet = $params{'quiet'};
106 26         60 my $strict = $params{'strict'};
107              
108 26 100       73 if(my $date = $params{'date'}) {
109             # TODO: Needs much more sanity checking
110 23 100 100     184 if(($date =~ /^bef\s/i) || ($date =~ /^aft\s/i)) {
111 3 100       16 Carp::carp("$date is invalid, need an exact date to create a DateTime")
112             unless($quiet);
113 3         675 return;
114             }
115 20 100       107 if($date =~ /^31 Nov/) {
116 1         7 Carp::carp("$date is invalid, there are only 30 days in November");
117 1         361 return;
118             }
119 19         59 my $dfn = $self->{'dfn'};
120 19 100       67 if(!defined($dfn)) {
121 11         83 $self->{'dfn'} = $dfn = DateTime::Format::Natural->new();
122             }
123 19 100       77659 if($date =~ /^\s*(.+\d\d)\s*\-\s*(.+\d\d)\s*$/) {
124 1         10 Carp::carp("Changing date '$date' to 'bet $1 and $2'");
125 1         337 $date = "bet $1 and $2";
126             }
127 19 100       102 if($date =~ /^bet (.+) and (.+)/i) {
128 3 100       15 if(wantarray) {
129 1         8 return $self->parse_datetime($1), $self->parse_datetime($2);
130             }
131 2         14 return;
132             }
133 16 50       103 if($date !~ /^\d{3,4}$/) {
134 16 100       111 if($date =~ /^(\d{1,2})\s+([A-Z]{4,}+)\s+(\d{3,4})$/i) {
135 3 100 100     29 if((!$strict) && (my $abbrev = $months{$2})) {
136 1         7 $date = "$1 $abbrev $3";
137             } else {
138 2 50       14 Carp::croak("Unparseable date $date - often because the month name isn't 3 letters") unless($quiet);
139             }
140             }
141 14 50 33     86 if(($date =~ /^\d/) && (my $d = $self->_date_parser_cached($date))) {
142 14         112 return $dfn->parse_datetime($d->{'canonical'});
143             }
144 0 0 0     0 if(($date !~ /^(Abt|ca?)/i) && ($date =~ /^[\w\s]+$/)) {
145             # ACOM exports full month names and non-standard format dates e.g. U.S. format MMM, DD YYYY
146             # TODO: allow that when mot in strict mode
147 0 0       0 if(my $rc = $dfn->parse_datetime($date)) {
148 0         0 return $rc;
149             }
150 0         0 Carp::croak("Can't parse date '$date'");
151             }
152             }
153             } else {
154 3         10 Carp::croak('Usage: parse_datetime(date => $date)');
155             }
156             }
157              
158             # Parse Gedcom format dates
159             # Genealogy::Gedcom::Date is expensive, so cache results
160             sub _date_parser_cached
161             {
162 14     14   32 my $self = shift;
163 14         27 my %params;
164              
165 14 50       89 if(ref($_[0]) eq 'HASH') {
    50          
    50          
166 0         0 %params = %{$_[0]};
  0         0  
167             } elsif(ref($_[0])) {
168 0         0 Carp::croak('Usage: _date_parser_cached(date => $date)');
169             } elsif(scalar(@_) % 2 == 0) {
170 0         0 %params = @_;
171             } else {
172 14         43 $params{'date'} = shift;
173             }
174              
175 14         32 my $date = $params{'date'};
176              
177 14 100       74 if($self->{'all_dates'}{$date}) {
178 2         9 return $self->{'all_dates'}{$date};
179             }
180 12         27 my $date_parser = $self->{'date_parser'};
181 12 100       46 if(!defined($date_parser)) {
182 10         250 $date_parser = $self->{'date_parser'} = Genealogy::Gedcom::Date->new();
183             }
184              
185 12         2267694 my $d;
186 12         45 eval {
187 12         95 $d = $date_parser->parse(date => $date);
188             };
189 12 50       289413 if(my $error = $date_parser->error()) {
190 0         0 Carp::carp("$date: '$error'");
191 0         0 return;
192             }
193 12 50 33     213 if($d && (ref($d) eq 'ARRAY')) {
194 12         37 $d = @{$d}[0];
  12         49  
195 12         67 $self->{'all_dates'}{$date} = $d;
196             }
197 12         101 return $d;
198             }
199              
200             1;
201              
202             =head1 AUTHOR
203              
204             Nigel Horne, C<< <njh at bandsman.co.uk> >>
205              
206             =head1 BUGS
207              
208             =head1 SEE ALSO
209              
210             L<Genealogy::Gedcom::Date> and
211             L<DateTime>
212              
213             =head1 SUPPORT
214              
215             You can find documentation for this module with the perldoc command.
216              
217             perldoc DateTime::Format::Gedcom
218              
219             You can also look for information at:
220              
221             =over 4
222              
223             =item * RT: CPAN's request tracker
224              
225             L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=DateTime-Format-Gedcom>
226              
227             =item * CPAN Ratings
228              
229             L<http://cpanratings.perl.org/d/DateTime-Format-Gedcom>
230              
231             =back
232              
233             =head1 LICENSE AND COPYRIGHT
234              
235             Copyright 2018-2020 Nigel Horne.
236              
237             This program is released under the following licence: GPL2
238              
239             =cut
240              
241             1;