File Coverage

blib/lib/Time/Normalize.pm

Criterion	Covered	Total	%
statement	205	223	91.9
branch	158	184	85.8
condition	42	60	70.0
subroutine	26	29	89.6
pod	15	18	83.3
total	446	514	86.7

=for gpg
-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1

=head1 NAME

Time::Normalize - Convert time and date values into standardized components.

=head1 VERSION

This is version 0.09 of Time::Normalize, April 23, 2014.

=cut

use strict;
package Time::Normalize;
$Time::Normalize::VERSION = '0.09';
use Carp;

use Exporter;
use vars qw/@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS/;
@ISA       = qw/Exporter/;
@EXPORT    = qw/normalize_hms normalize_time normalize_ymd normalize_gmtime
                normalize_month normalize_year normalize_ym
                normalize_ymd3 normalize_ym3
                normalize_ymdhms  normalize_rct
               /;
@EXPORT_OK = (@EXPORT, qw(mon_name mon_abbr day_name day_abbr days_in is_leap));
%EXPORT_TAGS = (all => \@EXPORT_OK);

# Is POSIX available?
eval {require POSIX };
my $have_posix = $@? 0 : 1;

# Delay loading Carp until needed
sub _croak
{
    require Carp;
    goto &Carp::croak;
}

# Most error messages in this module look very similar.
# This standardizes them:
sub _bad
{
    my ($what, $value) = @_;
    $value = '(undefined)' if !defined $value;
    _croak qq{Time::Normalize: Invalid $what: "$value"};
}

# Current locale.
my $locale;

# Month names; Month names abbrs, Weekday names, Weekday name abbrs.
#  *All Mixed-Case!*
our (@Mon_Name, @Mon_Abbr, @Day_Name, @Day_Abbr);
# Lookup: string-month => numeric-month (also string-day => numeric-day)
our %number_of;
# We need english-only names to parse R::C::t's 'mail' format.
my  $mail_month_number;
our $use_mail_months;

# Current year and century.  Used for guessing century of two-digit years.
my $current_year = (localtime)[5] + 1900;
my ($current_century, $current_yy) = $current_year =~ /(\d\d)(\d\d)/;

# Number of days in each (1-based) month (except February).
my @num_days_in = qw(0 31 29 31 30 31 30 31 31 30 31 30 31);

sub days_in
{
    _croak "Too few arguments to days_in"  if @_ < 2;
    _croak "Too many arguments to days_in" if @_ > 2;
    my ($m,$y) = @_;
    _croak qq{Non-integer month "$m" for days_in}  if $m !~ /\A\s* \d+ \s*\z/x;
    _bad('month', $m) if $m < 1  ||  $m > 12;
    return $num_days_in[$m] if $m != 2;

    # February
    return is_leap($y)? 29 : 28;
}

# Is a leap year?
sub is_leap
{
    _croak "Too few arguments to is_leap"  if @_ < 1;
    _croak "Too many arguments to is_leap" if @_ > 1;
    my $year = shift;
    return !($year%4) && ( ($year%100) || !($year%400) );
}

# Quickie function to pad a number with a leading 0.
sub _lead0 { $_[0] > 9? $_[0]+0 : '0'.($_[0]+0)}

# Compute day of week, using Zeller's congruence
sub _dow
{
    my ($Y, $M, $D) = @_;

    $M -= 2;
    if ($M < 1)
    {
        $M += 12;
        $Y--;
    }
    my $C = int($Y/100);
    $Y %= 100;

    return (int((26*$M - 2)/10) + $D + $Y + int($Y/4) + int($C/4) - 2*$C) % 7;
}


# Internal function to initialize locale info.
sub _setup_locale
{
    # Do nothing if locale has not changed since %names was set up.
    my $locale_in_use;
    $locale_in_use = $have_posix? POSIX::setlocale(POSIX::LC_TIME()) : 'no posix; use defaults';
    $locale_in_use = q{} if  !defined $locale_in_use;

    # No changes needed
    return if defined $locale  &&  $locale eq $locale_in_use;

    $locale = $locale_in_use;

    eval
    {
        require I18N::Langinfo;
        I18N::Langinfo->import ('langinfo');
        @Mon_Name  = map langinfo($_), (
                                        I18N::Langinfo::MON_1(),
                                        I18N::Langinfo::MON_2(),
                                        I18N::Langinfo::MON_3(),
                                        I18N::Langinfo::MON_4(),
                                        I18N::Langinfo::MON_5(),
                                        I18N::Langinfo::MON_6(),
                                        I18N::Langinfo::MON_7(),
                                        I18N::Langinfo::MON_8(),
                                        I18N::Langinfo::MON_9(),
                                        I18N::Langinfo::MON_10(),
                                        I18N::Langinfo::MON_11(),
                                        I18N::Langinfo::MON_12(),
                                       );
        @Mon_Abbr  = map langinfo($_), (
                                        I18N::Langinfo::ABMON_1(),
                                        I18N::Langinfo::ABMON_2(),
                                        I18N::Langinfo::ABMON_3(),
                                        I18N::Langinfo::ABMON_4(),
                                        I18N::Langinfo::ABMON_5(),
                                        I18N::Langinfo::ABMON_6(),
                                        I18N::Langinfo::ABMON_7(),
                                        I18N::Langinfo::ABMON_8(),
                                        I18N::Langinfo::ABMON_9(),
                                        I18N::Langinfo::ABMON_10(),
                                        I18N::Langinfo::ABMON_11(),
                                        I18N::Langinfo::ABMON_12(),
                                       );
        @Day_Name  = map langinfo($_), (
                                        I18N::Langinfo::DAY_1(),
                                        I18N::Langinfo::DAY_2(),
                                        I18N::Langinfo::DAY_3(),
                                        I18N::Langinfo::DAY_4(),
                                        I18N::Langinfo::DAY_5(),
                                        I18N::Langinfo::DAY_6(),
                                        I18N::Langinfo::DAY_7(),
                                       );
        @Day_Abbr  = map langinfo($_), (
                                        I18N::Langinfo::ABDAY_1(),
                                        I18N::Langinfo::ABDAY_2(),
                                        I18N::Langinfo::ABDAY_3(),
                                        I18N::Langinfo::ABDAY_4(),
                                        I18N::Langinfo::ABDAY_5(),
                                        I18N::Langinfo::ABDAY_6(),
                                        I18N::Langinfo::ABDAY_7(),
                                       );
        # make the month arrays 1-based:
        for (\@Mon_Name, \@Mon_Abbr)
        {
            unshift @$_, 'n/a';
        }
    };
    if ($@)    # If internationalization didn't work for some reason, go with English.
    {
        @Mon_Name = qw(n/a January February March April May June July August September October November December);
        @Mon_Abbr = map substr($_,0,3), @Mon_Name;
        @Day_Name = qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday);
        @Day_Abbr = map substr($_,0,3), @Day_Name;
    }

    %number_of = ();
    for (1..12)
    {
        $number_of{uc $Mon_Name[$_]} = $number_of{uc $Mon_Abbr[$_]} = $_;
    }
    # This module doesn't use reverse DOW lookups, but someone might want it.
    for (0..6)
    {
        $number_of{uc $Day_Name[$_]} = $number_of{uc $Day_Abbr[$_]} = $_;
    }
}

sub _init_mail_months
{
    my @abbrs  = qw(n/a Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
    %$mail_month_number = ();
    for (1..12)
    {
        $mail_month_number->{uc $abbrs[$_]} = $_;
    }
}

my %ap_from_ampm = (a => 'a', am => 'a', 'a.m.' => 'a', p => 'p', pm => 'p', 'p.m.' => 'p');
sub normalize_hms
{
    _croak "Too few arguments to normalize_hms"  if @_ < 2;
    _croak "Too many arguments to normalize_hms" if @_ > 4;
    my ($inh, $inm, $ins, $ampm) = @_;
    my ($hour24, $hour12, $minute, $second);
    my $ap;

    # First, normalize am/pm indicator
    if (defined $ampm  &&  length $ampm)
    {
        $ap = $ap_from_ampm{lc $ampm};
        _bad ('am/pm indicator', $ampm)  if !defined $ap;
    }

    # Check that the hour is in bounds
    _bad('hour', $inh) if $inh !~ /\A\s*  \d+  \s*\z/x;
    if (defined $ap)
    {
        # Range is from 1 to 12
        _bad('hour', $inh)  if $inh < 1  ||  $inh > 12;
        $hour12 = 0 + $inh;
        $hour24 = $hour12 == 12?  0 : $hour12;
        $hour24 += 12 if $ap eq 'p';
    }
    else
    {
        # Range is from 0 to 23
        _bad('hour', $inh)  if $inh < 0  ||  $inh > 23;
        $hour24 = $inh;
        $hour12 = $hour24 > 12?  $hour24 - 12 : $hour24 == 0? 12 : 0 + $hour24;
        $ap = $hour24 < 12? 'a' : 'p';
    }
    $hour24 = _lead0($hour24);

    # Minute check:  Numeric, range 0 to 59.
    _bad('minute', $inm)  if $inm !~ /\A\s*  \d+  \s*\z/x ||  $inm < 0  ||  $inm > 59;
    $minute = _lead0($inm);

    # Second check: Numeric, range 0 to 59.
    if (defined $ins  &&  length $ins)    # second is optional!
    {
        _bad('second', $ins)  if $ins !~ /\A\s*  \d+  \s*\z/x  ||  $ins < 0  ||  $ins > 59;
        $second = $ins;
    }
    else
    {
        $second = 0;
    }
    $second = _lead0($second);

    my $sec_since_midnight = $second + 60 * ($minute + 60 * $hour24);
    return wantarray? ($hour24, $minute, $second, $hour12, $ap, $sec_since_midnight)
        : {
            h12  => $hour12,
            h24  => $hour24,
            hour => $hour24,
            min  => $minute,
            sec  => $second,
            ampm => $ap,
            since_midnight => $sec_since_midnight,
        };
}

sub normalize_ymd
{
    _croak "Too few arguments to normalize_ymd"  if @_ < 3;
    _croak "Too many arguments to normalize_ymd" if @_ > 3;
    my ($iny, $inm, $ind) = @_;
    my ($year, $month, $day);

    _setup_locale();

    # First, check year.
    $year = normalize_year($iny);

    # Decode the month.
    $month = normalize_month($inm);

    # Day: Numeric and within range for the given month/year
    _bad('day', $ind)
        if $ind !~ /\A\s*  \d+  \s*\z/x  ||  $ind < 1  ||  $ind > days_in($month, $year);
    $day = _lead0($ind);

    my $dow = _dow($year, $month, $day);

    return ($year, $month, $day,
            $dow, $Day_Name[$dow], $Day_Abbr[$dow],
            $Mon_Name[$month], $Mon_Abbr[$month])
        if wantarray;

    return
        {
          year => $year, mon => $month, day => $day,
          dow  => $dow,
          dow_name => $Day_Name[$dow],
          dow_abbr => $Day_Abbr[$dow],
          mon_name => $Mon_Name[$month],
          mon_abbr => $Mon_Abbr[$month],
        };
}

sub normalize_ymdhms
{
    _croak "Too few arguments to normalize_ymdhms"  if @_ < 5;
    _croak "Too many arguments to normalize_ymdhms" if @_ > 7;
    my ($iny, $inmon, $ind, $inhr, $inmin, $insec, $inampm) = @_;

    my $date = normalize_ymd($iny, $inmon, $ind);
    my $time = normalize_hms($inhr, $inmin, $insec, $inampm);

    return ($date->{year}, $date->{mon}, $date->{day},
            $time->{hour}, $time->{min}, $time->{sec})
        if wantarray;

    return { %$date, %$time };
}

# Normalize values returned from Regexp::Common::time
sub normalize_rct
{
    my ($type, @values) = @_;
    $type =~ tr/24//d;
    $type = lc $type;

    # First element is "whole match", which is useless here.
    shift @values;

    my ($yr, $mo, $dy, $hr, $mn, $sc, $tz, $am);

    # How we proceed depends on which pattern captured the values.
    if ($type eq 'iso')
    {
        ($yr, $mo, $dy, $hr, $mn, $sc) = @values;
        return normalize_ymdhms($yr, $mo, $dy, $hr, $mn, $sc);
    }
    elsif ($type eq 'mail')
    {
        ($dy, $mo, $yr, $hr, $mn, $sc) = @values;
        local $use_mail_months = 1;
        return normalize_ymdhms($yr, $mo, $dy, $hr, $mn, $sc);
    }
    elsif ($type eq 'american')
    {
        ($mo, $dy, $yr) = @values;
        $yr =~ s/\A'//;    # "american" year might have leading apostrophe
        return normalize_ymd($yr, $mo, $dy);
    }
    elsif ($type eq 'ymd')
    {
        ($yr, $mo, $dy) = @values;
        return normalize_ymd($yr, $mo, $dy);
    }
    elsif ($type eq 'mdy')
    {
        ($mo, $dy, $yr) = @values;
        return normalize_ymd($yr, $mo, $dy);
    }
    elsif ($type eq 'dmy')
    {
        ($dy, $mo, $yr) = @values;
        return normalize_ymd($yr, $mo, $dy);
    }
    elsif ($type eq 'hms')
    {
        ($hr, $mn, $sc, $am) = @values;
        return normalize_hms($hr, $mn, $sc, $am);
    }
    else
    {
        _croak qq{Unknown Regexp::Common::time pattern: "$type"};
    }
}

# Like normalize_ymd, but only returns the Y, M, and D values.
# So you can do: $date = join '/' => normalize_ymd3 ($input_yr, $input_mo, $input_dy);
sub normalize_ymd3
{
    _croak "Too few arguments to normalize_ymd3"  if @_ < 3;
    _croak "Too many arguments to normalize_ymd3" if @_ > 3;
    my @ymd = normalize_ymd(@_);
    return @ymd[0,1,2];
}

# Like normalize_ym, but only returns the Y, M, and D values.
# So you can do: $date = join '/' => normalize_ym3 ($input_yr, $input_mo);
sub normalize_ym3
{
    _croak "Too few arguments to normalize_ym3"  if @_ < 3;
    _croak "Too many arguments to normalize_ym3" if @_ > 3;
    my @ymd = normalize_ym(@_);
    return @ymd[0,1,2];
}

# Like normalize_hms, but only returns the H, M, and S values.
# So you can do: $time = join ':' => normalize_hms3 ($input_hr, $input_min, $input_sec);
sub normalize_hms3
{
    _croak "Too few arguments to normalize_hms3"  if @_ < 2;
    _croak "Too many arguments to normalize_hms3" if @_ > 4;
    my @hms = normalize_hms(@_);
    return @hms[0,1,2];
}

sub normalize_month
{
    _croak "Too few arguments to normalize_month"  if @_ < 1;
    _croak "Too many arguments to normalize_month" if @_ > 1;
    _setup_locale;
    my $inm = shift;
    my $month;

    _bad('month', $inm) if !defined $inm;

    # Decode the month.
    if ($inm =~ /\A\s*  \d+  \s*\z/x)
    {
        # Numeric.  Simple 1-12 check.
        _bad('month', $inm)  if $inm < 1  ||  $inm > 12;
        $month = $inm;
    }
    else
    {
        # Might be a character month name
        if ($use_mail_months)
        {
            _init_mail_months  if !defined $mail_month_number;
            $month = $mail_month_number->{uc $inm};
        }
        else
        {
            $month = $number_of{uc $inm};
        }
        _bad('month', $inm)  if !defined $month;
    }
    return _lead0($month);
}

sub normalize_year
{
    _croak "Too few arguments to normalize_year"  if @_ < 1;
    _croak "Too many arguments to normalize_year" if @_ > 1;
    my $iny = shift;

    if ($iny =~ /\A\s*  \d{4}  \s*\z/x)
    {
        # Four-digit year.  Good.
        return sprintf '%04d', $iny+0;
    }

    if ($iny =~ /\A\s*  \d{2}  \s*\z/x)
    {
        # Two-digit year.  Guess the century.

        # If curr yy is <= 50, current century numbers are 0 - yy+50
        if ($current_yy <= 50)
        {
            return $iny + 100 * ($iny <= $current_yy+50?  $current_century : $current_century-1);
        }
        # If curr yy is > 50, current century numbers are yy-50 - 99
        else
        {
            return $iny + 100 * ($iny <= $current_yy-50?  $current_century+1 : $current_century);
        }
    }

    _bad('year', $iny);
}

sub normalize_ym
{
    _croak "Too few arguments to normalize_ym"  if @_ < 2;
    _croak "Too many arguments to normalize_ym" if @_ > 2;
    my ($iny, $inm) = @_;

    my ($year, $month) = (normalize_year($iny), normalize_month($inm));
    my $day = days_in ($month, $year);
    return normalize_ymd($year, $month, $day);
}


sub normalize_time
{
    _croak "Too many arguments to normalize_time" if @_ > 1;
    _bad ('time', $_[0])  if @_ == 1  &&  $_[0] !~ /\A\s*  \d+  \s*\z/x;
    my @t = @_?  localtime($_[0]) : localtime;
    return _normalize_gm_and_local_times(@t);
}

sub normalize_gmtime
{
    _croak "Too many arguments to normalize_gmtime" if @_ > 1;
    _bad ('time', $_[0])  if @_ == 1  &&  $_[0] !~ /\A\s*  \d+  \s*\z/x;
    my @t = @_?  gmtime($_[0]) : gmtime;
    return _normalize_gm_and_local_times(@t);
}

sub _normalize_gm_and_local_times
{
    my @t = @_;

    _setup_locale();

    if (wantarray)
    {
        my ($h24, $min, $sec, $h12, $ap, $ssm) = normalize_hms ($t[2], $t[1], $t[0]);
        my ($y4, $mon, $day, $dow, $dow_name, $dow_abbr, $mon_name, $mon_abbr)
            = normalize_ymd ($t[5] + 1900, $t[4] + 1, $t[3]);

        return ($sec, $min, $h24,
                $day, $mon, $y4,
                $dow, $t[7], $t[8],
                $h12, $ap, $ssm,
                $dow_name, $dow_abbr,
                $mon_name, $mon_abbr);
    }

    # Scalar.  Return hashref.
    my $hms_href = normalize_hms ($t[2], $t[1], $t[0]);
    my $ymd_href = normalize_ymd ($t[5] + 1900, $t[4] + 1, $t[3]);
    return { %$hms_href, %$ymd_href, yday => $t[7], isdst => $t[8] };
}

sub mon_name
{
    _croak "Too many arguments to mon_name" if @_ > 1;
    _croak "Too few arguments to mon_name"  if @_ < 1;
    my $mon = shift;
    _croak qq{Non-integer month "$mon" for mon_name}  if $mon !~ /\A\s* \d+ \s*\z/x;
    _bad('month', $mon) if $mon < 1  ||  $mon > 12;

    _setup_locale;
    return $Mon_Name[$mon];
}

sub mon_abbr
{
    _croak "Too many arguments to mon_abbr" if @_ > 1;
    _croak "Too few arguments to mon_abbr"  if @_ < 1;
    my $mon = shift;
    _croak qq{Non-integer month "$mon" for mon_abbr}  if $mon !~ /\A\s* \d+ \s*\z/x;
    _bad('month', $mon) if $mon < 1  ||  $mon > 12;

    _setup_locale;
    return $Mon_Abbr[$mon];
}

sub day_name
{
    _croak "Too many arguments to day_name" if @_ > 1;
    _croak "Too few arguments to day_name"  if @_ < 1;
    my $day = shift;
    _croak qq{Non-integer weekday "$day" for day_name}  if $day !~ /\A\s* \d+ \s*\z/x;
    _bad('weekday-number', $day) if $day < 0  ||  $day > 6;

    _setup_locale;
    return $Day_Name[$day];
}

sub day_abbr
{
    _croak "Too many arguments to day_abbr" if @_ > 1;
    _croak "Too few arguments to day_abbr"  if @_ < 1;
    my $day = shift;
    _croak qq{Non-integer weekday "$day" for day_abbr}  if $day !~ /\A\s* \d+ \s*\z/x;
    _bad('weekday-number', $day) if $day < 0  ||  $day > 6;

    _setup_locale;
    return $Day_Abbr[$day];
}

1;
__END__