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 7     7   37 use strict;
  7         13  
  7         305  
4              
5 7     7   34 use vars qw($VERSION @ISA);
  7         10  
  7         442  
6              
7             our $VERSION = '0.06';
8             @ISA = qw/Gedcom::Date/;
9              
10 7     7   35 use Gedcom::Date;
  7         11  
  7         178  
11 7     7   9416 use DateTime 0.15;
  7         696672  
  7         10273  
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 100 my ($class, $str) = @_;
23              
24 56 50       404 my ($cal, $date) =
25             $str =~ /^(?:\@#(.+)\@\s+)?(.+)$/
26             or return; # Not a simple date
27              
28 56   50     268 $cal ||= 'GREGORIAN';
29 56 50       170 return unless exists $months{$cal};
30              
31 56 100       554 my ($d, $month, $y) =
32             $date =~ /^(?:(?:(\d+)\s+)?(\w+)\s+)?(\d+)$/
33             or return;
34              
35 53         312 my %known = ( d => defined $d, m => defined $month, y => 1 );
36 53   100     141 $d ||= 1; # Handling of incomplete dates is not correct yet
37 53   66     120 $month ||= $months{$cal}[6];
38              
39 53         58 my $m;
40 53         60 for (0..$#{$months{$cal}}) {
  53         181  
41 636 100       1549 $m = $_+1 if $month eq $months{$cal}[$_];
42             }
43 53 50       141 defined($m) or return;
44              
45 53 50 50     79 my $dt = eval {DateTime->new( year => $y, month => $m, day => $d||15 )}
  53         305  
46             or return;
47              
48 53         14900 return $dt, \%known;
49             }
50              
51             sub parse {
52 56     56 1 100 my $class = shift;
53 56         111 my ($str) = @_;
54              
55 56 100       189 my ($dt, $known) = Gedcom::Date::Simple->parse_datetime($str)
56             or return;
57              
58 53         294 my $self = bless {
59             datetime => $dt,
60             known => $known,
61             }, $class;
62              
63 53         770 return $self;
64             }
65              
66             sub clone {
67 26     26 1 49 my $self = shift;
68              
69 26         430 my $clone = bless {
70             datetime => $self->{datetime}->clone,
71 26         95 known => { %{$self->{known}} },
72             }, ref $self;
73              
74 26         138 return $clone;
75             }
76              
77             sub gedcom {
78 39     39 1 2911 my $self = shift;
79              
80 39 50       185 if (!defined $self->{gedcom}) {
81 39         148 $self->{datetime}->set(locale => 'en');
82 39         13400 my $str;
83 39 100       141 if ($self->{known}{d}) {
    100          
84 31         120 $str = uc $self->{datetime}->strftime('%d %b %Y');
85             } elsif ($self->{known}{m}) {
86 4         28 $str = uc $self->{datetime}->strftime('%b %Y');
87             } else {
88 4         39 $str = $self->{datetime}->strftime('%Y');
89             }
90 39         2121 $str =~ s/\b0+(\d)/$1/g;
91 39         93 $self->{gedcom} = $str;
92             }
93 39         185 $self->{gedcom};
94             }
95              
96             sub from_datetime {
97 1     1 1 3 my ($class, $dt) = @_;
98              
99 1         10 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 24 my ($self, $type) = @_;
107              
108 11   100     33 $type ||= 'abt';
109 11         96 Gedcom::Date::Approximated->new( date => $self,
110             type => $type,
111             );
112             }
113              
114             sub latest {
115 2     2 1 12 my ($self) = @_;
116              
117 2         4 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         10 return $dt;
129             }
130              
131             sub earliest {
132 2     2 1 3 my ($self) = @_;
133              
134 2         4 my $dt = $self->{datetime};
135 2 50       18 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         6 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 17 my ($self, $lang) = @_;
164              
165 9 100       68 if ($self->{known}{d}) {
    100          
166 3         17 return ($text{$lang}[0], $self);
167             } elsif ($self->{known}{m}) {
168 3         13 return ($text{$lang}[1], $self);
169             } else {
170 3         14 return ($text{$lang}[2], $self);
171             }
172             }
173              
174             sub _date_as_text {
175 45     45   71 my ($self, $locale) = @_;
176              
177 45         87 my $dt = $self->{datetime};
178 45         167 $dt->set(locale => $locale);
179              
180 45 100       16565 if ($self->{known}{d}) {
    100          
181 39         98 my $format = $dt->locale->long_date_format;
182 39         12047 $format =~ s/%y\b/%Y/g; # never, EVER, use 2-digit years
183 39         151 return $dt->strftime($format);
184             } elsif ($self->{known}{m}) {
185 3         9 return $dt->strftime('%B %Y');
186             } else {
187 3         11 return $dt->year;
188             }
189             }
190              
191             sub add {
192 21     21 1 1985 my ($self, %p) = @_;
193 21         49 my $secret = delete $p{secret};
194              
195 21         128 $self->{datetime}->add(%p);
196              
197 21 100       13966 $p{months} = 0 if exists $p{days};
198 21 100       77 $p{years} = 0 if exists $p{months};
199              
200 21   100     111 $self->{known}{d} &&= exists $p{days};
201 21   100     90 $self->{known}{m} &&= exists $p{months};
202 21   33     191 $self->{known}{y} &&= exists $p{years};
203              
204 21 100       46 unless ($secret) {
205 9         37 my $d = $self->to_approximated('calculated');
206 9         17 %{ $self } = %{ $d };
  9         62  
  9         165  
207 9         52 bless $self, ref $d;
208             }
209              
210 21         71 return $self;
211             }
212              
213             1;
214              
215             __END__