| File: | blib/lib/Date/Age.pm |
| Coverage: | 89.5% |
| line | stmt | bran | cond | sub | time | code |
|---|---|---|---|---|---|---|
| 1 | package 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 | ||||||
| 12 | our @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 | ||||||
| 24 | our $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 | ||||||
| 85 | sub 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 | ||||||
| 174 | sub 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 | ||||||
| 200 | sub _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 | ||||||
| 205 | sub _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 | ||||||
| 227 | sub _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 | ||||||
| 251 | sub _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 | ||||||
| 266 | sub _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 | ||||||
| 273 | sub _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 | ||||||
| 282 | 1; | |||||
| 283 | ||||||