File Coverage

blib/lib/Gedcom/Date/Simple.pm
Criterion Covered Total %
statement 90 100 90.0
branch 33 46 71.7
condition 15 20 75.0
subroutine 15 16 93.7
pod 8 11 72.7
total 161 193 83.4


line stmt bran cond sub pod time code
1             package Gedcom::Date::Simple;
2              
3 6     6   32 use strict;
  6         12  
  6         171  
4              
5 6     6   28 use vars qw($VERSION @ISA);
  6         10  
  6         384  
6              
7             our $VERSION = '0.09';
8             @ISA = qw/Gedcom::Date/;
9              
10 6     6   29 use Gedcom::Date;
  6         11  
  6         168  
11 6     6   6424 use DateTime 0.15;
  6         272351  
  6         8160  
12              
13             my %months = (
14             JULIAN => [qw/JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC/],
15             GREGORIAN => [qw/JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC/],
16             'FRENCH R' => [qw/VEND BRUM FRIM NIVO PLUV VENT
17             GERM FLOR PRAI MESS THER FRUC COMP/],
18             HEBREW => [qw/TSH CSH KSL TVT SHV ADR ADS NSN IYR SVN TMZ AAV ELL/],
19             );
20              
21             sub parse_datetime {
22 56     56 0 89 my ($class, $str) = @_;
23              
24 56 50       331 my ($cal, $date) =
25             $str =~ /^(?:\@#(.+)\@\s+)?(.+)$/
26             or return; # Not a simple date
27              
28 56   50     261 $cal ||= 'GREGORIAN';
29 56 50       158 return unless exists $months{$cal};
30              
31 56 100       382 my ($d, $month, $y) =
32             $date =~ /^(?:(?:(\d+)\s+)?(\w+)\s+)?(\d+)$/
33             or return;
34              
35 53         227 my %known = ( d => defined $d, m => defined $month, y => 1 );
36 53   100     131 $d ||= 1; # Handling of incomplete dates is not correct yet
37 53   66     131 $month ||= $months{$cal}[6];
38              
39 53         72 my $m;
40 53         70 for (0..$#{$months{$cal}}) {
  53         211  
41 636 100       1675 $m = $_+1 if $month eq $months{$cal}[$_];
42             }
43 53 50       131 defined($m) or return;
44              
45 53 50 50     75 my $dt = eval {DateTime->new( year => $y, month => $m, day => $d||15 )}
  53         264  
46             or return;
47              
48 53         14021 return $dt, \%known;
49             }
50              
51             sub parse {
52 56     56 1 83 my $class = shift;
53 56         107 my ($str) = @_;
54              
55 56 100       147 my ($dt, $known) = Gedcom::Date::Simple->parse_datetime($str)
56             or return;
57              
58 53         191 my $self = bless {
59             datetime => $dt,
60             known => $known,
61             }, $class;
62              
63 53         595 return $self;
64             }
65              
66             sub clone {
67 26     26 1 47 my $self = shift;
68              
69             my $clone = bless {
70             datetime => $self->{datetime}->clone,
71 26         87 known => { %{$self->{known}} },
  26         353  
72             }, ref $self;
73              
74 26         124 return $clone;
75             }
76              
77             sub gedcom {
78 39     39 1 1954 my $self = shift;
79              
80 39 50       123 if (!defined $self->{gedcom}) {
81 39         133 $self->{datetime}->set(locale => 'en');
82 39         12198 my $str;
83 39 100       119 if ($self->{known}{d}) {
    100          
84 31         106 $str = uc $self->{datetime}->strftime('%d %b %Y');
85             } elsif ($self->{known}{m}) {
86 4         20 $str = uc $self->{datetime}->strftime('%b %Y');
87             } else {
88 4         22 $str = $self->{datetime}->strftime('%Y');
89             }
90 39         1995 $str =~ s/\b0+(\d)/$1/g;
91 39         99 $self->{gedcom} = $str;
92             }
93 39         179 $self->{gedcom};
94             }
95              
96             sub from_datetime {
97 1     1 1 2 my ($class, $dt) = @_;
98              
99 1         9 return bless {
100             datetime => $dt,
101             known => {d => 1, m => 1, y => 1},
102             }, $class;
103             }
104              
105             sub to_approximated {
106 11     11 0 20 my ($self, $type) = @_;
107              
108 11   100     34 $type ||= 'abt';
109 11         50 Gedcom::Date::Approximated->new( date => $self,
110             type => $type,
111             );
112             }
113              
114             sub latest {
115 2     2 1 4 my ($self) = @_;
116              
117 2         9 my $dt = $self->{datetime};
118 2 50       11 if (!$self->{known}{m}) {
    50          
119 0         0 $dt->truncate(to => 'year')
120             ->add(years => 1)
121             ->subtract(days => 1);
122             } elsif (!$self->{known}{d}) {
123 0         0 $dt->truncate(to => 'month')
124             ->add(months => 1)
125             ->subtract(days => 1);
126             }
127              
128 2         8 return $dt;
129             }
130              
131             sub earliest {
132 2     2 1 4 my ($self) = @_;
133              
134 2         4 my $dt = $self->{datetime};
135 2 50       11 if (!$self->{known}{m}) {
    50          
136 0         0 $dt->truncate(to => 'year');
137             } elsif (!$self->{known}{d}) {
138 0         0 $dt->truncate(to => 'month');
139             }
140              
141 2         8 return $dt;
142             }
143              
144             sub sort_date {
145 0     0 1 0 my ($self) = @_;
146              
147 0         0 my $dt = $self->{datetime};
148 0 0       0 if (!$self->{known}{m}) {
    0          
149 0         0 return $dt->strftime('%Y-??-??');
150             } elsif (!$self->{known}{d}) {
151 0         0 return $dt->strftime('%Y-%m-??');
152             }
153              
154 0         0 return $dt->strftime('%Y-%m-%d');
155             }
156              
157             my %text = (
158             en => ['on %0', 'in %0', 'in %0'],
159             nl => ['op %0', 'in %0', 'in %0'],
160             );
161              
162             sub text_format {
163 9     9 0 15 my ($self, $lang) = @_;
164              
165 9 100       31 if ($self->{known}{d}) {
    100          
166 3         13 return ($text{$lang}[0], $self);
167             } elsif ($self->{known}{m}) {
168 3         13 return ($text{$lang}[1], $self);
169             } else {
170 3         11 return ($text{$lang}[2], $self);
171             }
172             }
173              
174             sub _date_as_text {
175 45     45   63 my ($self, $locale) = @_;
176              
177 45         69 my $dt = $self->{datetime};
178 45         122 $dt->set(locale => $locale);
179              
180 45 100       12799 if ($self->{known}{d}) {
    100          
181 39         108 my $format = $dt->locale->date_format_long;
182 39         292 $format =~ s/%y\b/%Y/g; # never, EVER, use 2-digit years
183 39         110 return $dt->format_cldr($format);
184             } elsif ($self->{known}{m}) {
185 3         11 return $dt->strftime('%B %Y');
186             } else {
187 3         10 return $dt->year;
188             }
189             }
190              
191             sub add {
192 21     21 1 1972 my ($self, %p) = @_;
193 21         34 my $secret = delete $p{secret};
194              
195 21         98 $self->{datetime}->add(%p);
196              
197 21 100       12487 $p{months} = 0 if exists $p{days};
198 21 100       66 $p{years} = 0 if exists $p{months};
199              
200 21   100     96 $self->{known}{d} &&= exists $p{days};
201 21   100     84 $self->{known}{m} &&= exists $p{months};
202 21   33     93 $self->{known}{y} &&= exists $p{years};
203              
204 21 100       48 unless ($secret) {
205 9         23 my $d = $self->to_approximated('calculated');
206 9         14 %{ $self } = %{ $d };
  9         54  
  9         122  
207 9         41 bless $self, ref $d;
208             }
209              
210 21         63 return $self;
211             }
212              
213             1;
214              
215             __END__