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; |