File Coverage

File:blib/lib/Date/Age.pm
Coverage:89.5%

linestmtbrancondsubtimecode
1package Date::Age;
2
3
3
3
288661
4
use 5.010;
4
5
3
3
3
5
2
25
use strict;
6
3
3
3
5
32
78
use warnings;
7
8
3
3
3
6
3
73
use Carp qw(carp croak);
9
3
3
3
6
0
34
use Exporter 'import';
10
3
3
3
624
2435
1379
use Time::Local qw(timelocal);
11
12our @EXPORT_OK = qw(describe details);
13
14 - 22
=head1 NAME

Date::Age - Return an age or age range from date(s)

=head1 VERSION

Version 0.07

=cut
23
24our $VERSION = '0.07';
25
26 - 83
=head1 SYNOPSIS

  use Date::Age qw(describe details);

  print describe('1943', '2016-01-01'), "\n"; # '72-73'

  my $data = details('1943-05-01', '2016-01-01');
  # { min_age => 72, max_age => 72, range => '72', precise => 72 }

=head1 DESCRIPTION

This module calculates the age or possible age range between a date of birth
and another date (typically now or a death date).
It works even with partial dates.

=head1 METHODS

=head1 FUNCTIONS

=head2 describe($dob, $ref_date)

  my $range = describe($dob);
  my $range = describe($dob, $ref_date);

=over 4

=item $dob

Date of birth, in any format supported by C<details()>.

=item $ref_date

Optional reference date. If omitted, the current local date is used.

=back

Returns a string containing a human-readable age or age range for the supplied date of birth.

C<describe()> accepts a date of birth in any of the formats supported by
L</details> (year only, year-month, or full year-month-day).  An optional
reference date may also be provided; if omitted, the current local date is
used.

Because partial dates imply uncertainty, the routine may return either a
single age (e.g. C<"72">) or an age range (e.g. C<"72-73">).  Year-only and
year-month dates can span a range of possible birthdays, and therefore a
range of possible ages.

Examples:

  describe('1943');     # e.g. '80-81'
  describe('1943-05', '2016');  # '72-73'
  describe('1943-05-01', '2016-01-01');  # '72'

This routine is a convenience wrapper around C<details()> that returns only
the formatted range string.

=cut
84
85sub describe {
86
4
66446
        if($_[0] eq __PACKAGE__) {
87
0
0
                shift;
88        }
89
90
4
9
        croak('Usage: ', __PACKAGE__, '::describe($dob, $ref_date)') if(scalar(@_) == 0);
91
92
4
5
        my ($dob, $ref_date) = @_;
93
4
4
        my $info = details($dob, $ref_date);
94
3
5
        return $info->{range};
95}
96
97 - 172
=head2 details($dob, $ref_date)

  my $info = details($dob);
  my $info = details($dob, $ref_date);

=over 4

=item $dob

Date of birth, in any format supported by C<details()>.

=item $ref_date

Optional reference date. If omitted, the current local date is used.

=back

Returns a hashref describing the full computed age information.  This routine
performs the underlying date-range expansion and age calculation that
C<describe()> relies on.

The returned hashref contains:

=over 4

=item * C<min_age>

The minimum possible age based on the earliest possible birthday within the
supplied date specification.

=item * C<max_age>

The maximum possible age based on the latest possible birthday.

=item * C<range>

A string representation of the age or age range, such as C<"72"> or
C<"72-73">.

=item * C<precise>

If the age is unambiguous (e.g. the date of birth and reference date are both
fully specified), this is the exact age as an integer.  Otherwise it is
C<undef>.

=back

Supported date formats for both C<$dob> and C<$ref_date> are:

=over 4

=item * C<YYYY> - year only (e.g. C<1943>)

=item * C<YYYY-MM> - year and month (e.g. C<1943-05>)

=item * C<YYYY-MM-DD> - full date (e.g. C<1943-05-01>)

=back

Invalid or unrecognised date strings will cause the routine to C<croak()>.

Example:

  my $info = details('1943-05-01', '2016-01-01');

  # {
  #   min_age => 72,
  #   max_age => 72,
  #   range   => '72',
  #   precise => 72,
  # }

When the reference date is omitted, the current local date (YYYY-MM-DD) is
used.

=cut
173
174sub details {
175
13
3078
        if($_[0] eq __PACKAGE__) {
176
0
0
                shift;
177        }
178
179
13
11
        croak('Usage: ', __PACKAGE__, '::details($dob, $ref)') if(scalar(@_) == 0);
180
181
13
9
        my ($dob, $ref_date) = @_;
182
183
13
12
        my ($dob_early, $dob_late) = _parse_date_range($dob);
184
8
10
        my ($ref_early, $ref_late) = _parse_date_range($ref_date // _now_string());
185
186
8
7
        my $min_age = _calc_age_localtime($dob_late,  $ref_early);
187
8
7
        my $max_age = _calc_age_localtime($dob_early, $ref_late);
188
189
8
8
        my $range_str = $min_age == $max_age ? $min_age : "$min_age-$max_age";
190
8
8
        my $precise = ($min_age == $max_age) ? $min_age : undef;
191
192        return {
193
8
18
                min_age => $min_age,
194                max_age => $max_age,
195                range => $range_str,
196                precise => $precise,
197        };
198}
199
200sub _now_string {
201
1
1022
        my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime();
202
1
4
        return sprintf('%04d-%02d-%02d', $year + 1900, $mon + 1, $mday);
203}
204
205sub _calc_age_localtime {
206
16
14
        my ($dob, $ref) = @_;  # both in YYYY-MM-DD format
207
208        # Parse manually
209
16
21
        my ($dy, $dm, $dd) = split /-/, $dob;
210
16
17
        my ($ry, $rm, $rd) = split /-/, $ref;
211
212        # Convert to epoch for comparison
213        # Note: months are 0-11 for timelocal
214
16
19
        my $dob_epoch = timelocal(0, 0, 0, $dd, $dm - 1, $dy);
215
16
374
        my $ref_epoch = timelocal(0, 0, 0, $rd, $rm - 1, $ry);
216
217
16
287
        my $age = $ry - $dy;
218
219        # Check if birthday has occurred this year
220
16
15
        if ($ref_epoch < timelocal(0, 0, 0, $dd, $dm - 1, $ry)) {
221
8
181
                $age--;
222        }
223
224
16
140
        return $age;
225}
226
227sub _parse_date_range {
228
21
10
        my $date = shift;
229
230
21
43
        if ($date =~ /^\d{4}-\d{2}-\d{2}$/) {
231
16
12
                _validate_ymd_strict($date);
232
12
11
                return ($date, $date);
233        } elsif ($date =~ /^(\d{4})-(\d{2})$/) {
234
2
3
                my ($y, $m) = ($1, $2);
235
2
5
                die "Invalid month in date '$date'" if $m < 1 || $m > 12;
236
237
2
1
                my $start = "$y-$m-01";
238
2
2
                my $end = _end_of_month($y, $m);
239
240
2
3
                _validate_ymd_strict($start);
241
2
2
                _validate_ymd_strict($end);
242
243
2
2
                return ($start, $end);
244        } elsif ($date =~ /^(\d{4})$/) {
245
2
5
                return ("$1-01-01", "$1-12-31");
246        } else {
247
1
4
                die "Unrecognized date format: $date";
248        }
249}
250
251sub _validate_ymd_strict {
252
20
8
        my $date = $_[0];
253
254        # YYYY-MM-DD only
255
20
27
        return unless $date =~ /^(\d{4})-(\d{2})-(\d{2})$/;
256
20
27
        my ($y, $m, $d) = ($1, $2, $3);
257
258
20
39
        die "Invalid month in date '$date'" if $m < 1 || $m > 12;
259
260
18
8
        my @dim = (31, 28 + _is_leap($y), 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
261
18
12
        my $max_d = $dim[$m - 1];
262
263
18
35
        die "Invalid day in date '$date'" if $d < 1 || $d > $max_d;
264}
265
266sub _end_of_month {
267
5
980
        my ($y, $m) = @_;
268
269
5
4
        my @days_in_month = (31, 28 + _is_leap($y), 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
270
5
13
        return sprintf('%04d-%02d-%02d', $y, $m, $days_in_month[$m - 1]);
271}
272
273sub _is_leap {
274
27
239
        my $y = $_[0];
275
276
27
27
        return 1 if $y % 400 == 0;
277
13
14
        return 0 if $y % 100 == 0;
278
12
12
        return 1 if $y % 4 == 0;
279
4
7
        return 0;
280}
281
2821;
283