File Coverage

blib/lib/Time/P.pm

Criterion	Covered	Total	%
statement	234	339	69.0
branch	104	188	55.3
condition	52	87	59.7
subroutine	25	26	96.1
pod	1	1	100.0
total	416	641	64.9

use strict;
use warnings;
package Time::P;
$Time::P::VERSION = '0.024';
# ABSTRACT: Parse times from strings.

use Carp qw/ croak /;
use Exporter qw/ import /;
use Function::Parameters qw/ :lax /;
use Data::Munge qw/ list2re /;
use List::Util qw/ uniq /;

use Time::C::Util qw/ get_fmt_tok get_locale /;

use constant DEBUG => 0;

our @EXPORT = qw/ strptime /;


my %parser; %parser = (
    '%A'  => fun (:$locale) {
        my @weekdays = @{ get_locale(weekdays => $locale) };
        my $re = list2re(@weekdays);
        return qr"(?$re)";
    },
    '%a'  => fun (:$locale) {
        my @weekdays_abbr = @{ get_locale(weekdays_abbr => $locale) };
        my $re = list2re(@weekdays_abbr);
        return qr"(?$re)";
    },
    '%B'  => fun (:$locale) {
        my @months = @{ get_locale(months => $locale) };
        my $re = list2re(@months);
        return qr"(?$re)";
    },
    '%b'  => fun (:$locale) {
        my @months_abbr = @{ get_locale(months_abbr => $locale) };
        my $re = list2re(@months_abbr);
        return qr"(?$re)";
    },
    '%C'  => fun () { qr"(?[0-9][0-9])"; },
    '%-C' => fun () { qr"(?[0-9][0-9]?)"; },
    '%c'  => fun (:$locale) { _compile_fmt(get_locale(datetime => $locale), locale => $locale); },
    '%D'  => fun () {
        return $parser{'%m'}->(), qr!/!, $parser{'%d'}->(), qr!/!, $parser{'%y'}->();
    },
    '%d'  => fun () { qr"(?[0-9][0-9])"; },
    '%-d' => fun () { qr"(?[0-9][0-9]?)"; },
    '%EC' => fun (:$locale) {
        my @eras = _get_eras(period => $locale);
        return $parser{'%C'}->() if not @eras;
        my $re = list2re(@eras);
        return qr"(?$re)";
    },
    '%Ec' => fun (:$locale) { _compile_fmt(get_locale(era_datetime => $locale), locale => $locale); },
    '%EX' => fun (:$locale) { _compile_fmt(get_locale(era_time => $locale), locale => $locale); },
    '%Ex' => fun (:$locale) { _compile_fmt(get_locale(era_date => $locale), locale => $locale); },
    '%EY' => fun (:$locale) {
        my @eras = _get_eras(full => $locale);
        return $parser{'%Y'}->() if not @eras;

        my @ret = map { my $re = join "", _compile_fmt($_, locale => $locale); qr/$re/ } uniq @eras;
        my $full_re = join "|", @ret;
        return qr/$full_re/;
    },
    '%Ey' => fun () { qr"(?[0-9]+)"; },
    '%e'  => fun () { qr"(?:\s(?[0-9])|(?[0-9][0-9]))"; },
    '%-e' => fun () { qr"(?[0-9][0-9]?)"; },
    '%F'  => fun () {
        return $parser{'%Y'}->(), qr/-/, $parser{'%m'}->(), qr/-/, $parser{'%d'}->();
    },
    '%G'  => fun () { qr"(?[0-9]{4})"; },
    '%-G' => fun () { qr"(?[0-9]{1,4})"; },
    '%g'  => fun () { qr"(?[0-9][0-9])"; },
    '%-g' => fun () { qr"(?[0-9][0-9]?)"; },
    '%H'  => fun () { qr"(?[0-9][0-9])"; },
    '%-H' => fun () { qr"(?[0-9][0-9]?)"; },
    '%h'  => fun (:$locale) { $parser{'%b'}->(locale => $locale) },
    '%I'  => fun () { qr"(?[0-9][0-9])"; },
    '%-I' => fun () { qr"(?[0-9][0-9]?)"; },
    '%j'  => fun () { qr"(?[0-9]{3})"; },
    '%-j' => fun () { qr"(?[0-9]{1,3})"; },
    '%k'  => fun () { qr"(?:\s(?[0-9])|(?[0-9][0-9]))"; },
    '%-k' => fun () { qr"(?[0-9][0-9]?)"; },
    '%l'  => fun () { qr"(?:\s(?[0-9])|(?[0-9][0-9]))"; },
    '%-l' => fun () { qr"(?[0-9][0-9]?)"; },
    '%M'  => fun () { qr"(?[0-9][0-9])"; },
    '%-M' => fun () { qr"(?[0-9][0-9]?)"; },
    '%m'  => fun () { qr"(?[0-9][0-9])"; },
    '%-m' => fun () { qr"(?[0-9][0-9]?)"; },
    '%n'  => fun () { qr"\s+"; },
    '%OC' => fun (:$locale) {
        my @d = @{ get_locale(digits => $locale) };
        return $parser{'%d'}->() if not @d;
        croak "Not enough digits in alt_digits for $locale to represent %OC." if @d < 100;
        my $re = list2re(@d);
        return qr"(?$re)";
    },
    '%Od' => fun (:$locale) {
        my @d = @{ get_locale(digits => $locale) };
        return $parser{'%d'}->() if not @d;
        croak "Not enough digits in alt_digits for $locale to represent %Od." if @d < 32;
        my $re = list2re(@d);
        return qr"(?$re)";
    },
    '%Oe' => fun (:$locale) {
        my @d = @{ get_locale(digits => $locale) };
        return $parser{'%e'}->() if not @d;
        croak "Not enough digits in alt_digits for $locale to represent %Oe." if @d < 32;
        my $re = list2re(@d);
        return qr"(?$re)";
    },
    '%OH' => fun (:$locale) {
        my @d = @{ get_locale(digits => $locale) };
        return $parser{'%H'}->() if not @d;
        croak "Not enough digits in alt_digits for $locale to represent %OH." if @d < 24;
        my $re = list2re(@d);
        return qr"(?$re)";
    },
    '%OI' => fun (:$locale) {
        my @d = @{ get_locale(digits => $locale) };
        return $parser{'%I'}->() if not @d;
        croak "Not enough digits in alt_digits for $locale to represent %OI." if @d < 13;
        my $re = list2re(@d);
        return qr"(?$re)";
    },
    '%OM' => fun (:$locale) {
        my @d = @{ get_locale(digits => $locale) };
        return $parser{'%M'}->() if not @d;
        croak "Not enough digits in alt_digits for $locale to represent %OM." if @d < 60;
        my $re = list2re(@d);
        return qr"(?$re)";
    },
    '%Om' => fun (:$locale) {
        my @d = @{ get_locale(digits => $locale) };
        return $parser{'%m'}->() if not @d;
        croak "Not enough digits in alt_digits for $locale to represent %Om." if @d < 13;
        my $re = list2re(@d);
        return qr"(?$re)";
    },
    '%Op' => fun (:$locale) { $parser{'%p'}->(locale => $locale); }, # one %c spec in my_MM locale erroneously says %Op instead of %p
    '%OS' => fun (:$locale) {
        my @d = @{ get_locale(digits => $locale) };
        return $parser{'%S'}->() if not @d;
        croak "Not enough digits in alt_digits for $locale to represent %OS." if @d < 60;
        my $re = list2re(@d);
        return qr"(?$re)";
    },
    '%OU' => fun (:$locale) {
        my @d = @{ get_locale(digits => $locale) };
        return $parser{'%U'}->() if not @d;
        croak "Not enough digits in alt_digits for $locale to represent %OU." if @d < 54;
        my $re = list2re(@d);
        return qr"(?$re)";
    },
    '%Ou' => fun (:$locale) {
        my @d = @{ get_locale(digits => $locale) };
        return $parser{'%u'}->() if not @d;
        croak "Not enough digits in alt_digits for $locale to represent %Ou." if @d < 8;
        my $re = list2re(@d);
        return qr"(?$re)";
    },
    '%OV' => fun (:$locale) {
        my @d = @{ get_locale(digits => $locale) };
        return $parser{'%V'}->() if not @d;
        croak "Not enough digits in alt_digits for $locale to represent %OV." if @d < 54;
        my $re = list2re(@d);
        return qr"(?$re)";
    },
    '%OW' => fun (:$locale) {
        my @d = @{ get_locale(digits => $locale) };
        return $parser{'%W'}->() if not @d;
        croak "Not enough digits in alt_digits for $locale to represent %OW." if @d < 54;
        my $re = list2re(@d);
        return qr"(?$re)";
    },
    '%Ow' => fun (:$locale) {
        my @d = @{ get_locale(digits => $locale) };
        return $parser{'%w'}->() if not @d;
        croak "Not enough digits in alt_digits for $locale to represent %Ow." if @d < 7;
        my $re = list2re(@d);
        return qr"(?$re)";
    },
    '%Oy' => fun (:$locale) {
        my @d = @{ get_locale(digits => $locale) };
        return $parser{'%y'}->() if not @d;
        croak "Not enough digits in alt_digits for $locale to represent %Oy." if @d < 100;
        my $re = list2re(@d);
        return qr"(?$re)";
    },
    '%P'  => fun (:$locale) { $parser{'%p'}->(locale => $locale); }, # a few %r specs in some locales erroneously say %P instead of %p (wal_ET, ur_PK, pa_PK, iw_IL, he_IL, en_GB, dv_MV, cy_GB)
    '%p'  => fun (:$locale) {
        my @am_pm = @{ get_locale(am_pm => $locale) };
        return () unless @am_pm;
        my $re = list2re(@am_pm);
        return qr"(?$re)";
    },
    '%X'  => fun (:$locale) { _compile_fmt(get_locale(time => $locale), locale => $locale); },
    '%x'  => fun (:$locale) { _compile_fmt(get_locale(date => $locale), locale => $locale); },
    '%R'  => fun () {
        return $parser{'%H'}->(), qr/:/, $parser{'%M'}->();
    },
    '%r'  => fun (:$locale) { _compile_fmt(get_locale(time_ampm => $locale), locale => $locale); },
    '%S'  => fun () { qr"(?[0-9][0-9])"; },
    '%-S' => fun () { qr"(?[0-9][0-9]?)"; },
    '%s'  => fun () { qr"\s*(?[0-9]+)"; },
    '%T'  => fun () {
        return $parser{'%H'}->(), qr/:/, $parser{'%M'}->(), qr/:/, $parser{'%S'}->();
    },
    '%t'  => fun () { qr"\s+"; },
    '%U'  => fun () { qr"(?[0-9][0-9])"; },
    '%-U' => fun () { qr"(?[0-9][0-9]?)"; },
    '%u'  => fun () { qr"(?[0-9])"; },
    '%V'  => fun () { qr"(?[0-9][0-9])"; },
    '%-V' => fun () { qr"(?[0-9][0-9]?)"; },
    '%v'  => fun (:$locale) {
        return $parser{'%e'}->(), qr/-/, $parser{'%b'}->(locale => $locale), qr/-/, $parser{'%Y'}->()
    },
    '%W'  => fun () { qr"(?[0-9][0-9])"; },
    '%-W' => fun () { qr"(?[0-9][0-9]?)"; },
    '%w'  => fun () { qr"(?[0-9])"; },
    '%Y'  => fun () { qr"(?-?[0-9]{4})"; },
    '%-Y' => fun () { qr"(?-?[0-9]{1,4})"; },
    '%y'  => fun () { qr"(?[0-9][0-9])"; },
    '%-y' => fun () { qr"(?[0-9][0-9]?)"; },
    '%Z'  => fun () { qr"(?\S+)"; },
    '%z'  => fun () { qr"(?[-+][0-9][0-9](?::?[0-9][0-9])?)"; },
    '%%'  => fun () { qr"%"; },
);


fun strptime ($str, $fmt, :$locale = 'C', :$strict = 1, :$struct = {}) {
    my %parse = ();

    my @res = _compile_fmt($fmt, locale => $locale);

    croak "Could not match '%s' using '%s'.", $str, $fmt if not @res;

    @res = (qr/^/, @res, qr/$/) if $strict;

    my $re;
    while (defined ($re = shift @res) and $str =~ m/\G$re/gc) {
        warn "matched with $re\n" if DEBUG;
        %parse = (%parse, %+);
    }

    if (@res) {
        croak sprintf "Could not match '%s' using '%s'. Match failed at position %d (%s) while trying to match with /%s/.", $str, $fmt, pos($str), substr($str, pos($str)), $re;
    }

    $struct = { %$struct, _coerce_struct(\%parse, $struct, locale => $locale) };

    return %$struct;
}

fun _compile_fmt ($fmt, :$locale) {
    my @res = ();

    my $pos = 0;

    # _get_tok will increment $pos for us
    while (defined(my $tok = get_fmt_tok($fmt, $pos))) {
        if (exists $parser{$tok}) {
            my @p_res = $parser{$tok}->(locale => $locale);
            warn "pushing @p_res to list\n" if DEBUG;
            push @res, @p_res;
        } elsif ($tok =~ /^%/) {
            croak "Unsupported format specifier: $tok";
        } else {
            my $re = qr/\Q$tok\E/;
            warn "pushing $re to list\n" if DEBUG;
            push @res, $re;
        }
    }

    warn "returning @res\n" if DEBUG;
    return @res;
}

fun _get_mday ($struct, :$locale) {
    my $mday = $struct->{'d'};
    if (not defined $mday) { $mday = $struct->{'e'}; }
    if (not defined $mday and defined(my $Od = $struct->{Od})) {
        my @d = @{ get_locale(digits => $locale) };
        $mday = _get_index($Od, @d);
    }
    if (not defined $mday and defined(my $Oe = $struct->{Oe})) {
        my @d = @{ get_locale(digits => $locale) };
        $mday = _get_index($Oe, @d);
    }

    return $mday;
}

fun _get_year ($struct, :$locale) {
    my $wyear = 0;
    my $year = $struct->{'Y'};
    if (not defined $year) {
        if (defined $struct->{'G'}) {
            $year = $struct->{'G'};
            $wyear = 1;
        } elsif (defined $struct->{'C'}) {
            $year = $struct->{'C'} * 100;
            $year += $struct->{'y'} if defined $struct->{'y'};
            if (defined $struct->{'g'} and not defined $struct->{'y'}) {
                $year += $struct->{'g'};
                $wyear = 1;
            }
        } elsif (defined $struct->{'y'}) {
            $year = $struct->{'y'} + 1900;
            require Time::C;
            if ($year < (Time::C->now_utc()->year - 50)) { $year += 100; }
        } elsif (defined $struct->{'g'}) {
            $year = $struct->{'g'} + 1900;
            require Time::C;
            if ($year < (Time::C->now_utc()->year - 50)) { $year += 100; }
            $wyear = 1;
        }
    }
    if (not defined $year) {
        my $Ey = $struct->{Ey};
        my $EC = $struct->{EC};

        if (defined $EC) {
            my @eras = @{ get_locale(era => $locale) };
            foreach my $era (@eras) {
                my @fields = split /:/, $era;
                next if $EC ne $fields[4];

                my %s = strptime($fields[2], "%-Y/%m/%d");
                $s{year}++ if $s{year} < 1;
                $year = $s{year};
                $year += $Ey - $fields[1] if defined $Ey;
                $year-- if not defined $Ey;
                last;
            }
        } elsif (defined $Ey) {
            my @eras = @{ get_locale(era => $locale) };
            foreach my $era (@eras) {
                my @fields = split /:/, $era;

                my %s = strptime($fields[2], "%-Y/%m/%d");
                $s{year}++ if $s{year} < 1;
                require Time::C;
                next if $s{year} > Time::C->now_utc()->year;

                $year = $s{year} + $Ey - $fields[1];
                last;
            }
        }
    }
    if (not defined $year and defined(my $Oy = $struct->{Oy})) {
        my @d = @{ get_locale(digits => $locale) };
        if (defined(my $C = $struct->{C})) {
            $year = $C * 100;
        } elsif (defined(my $OC = $struct->{OC})) {
            $year = _get_index($OC, @d) * 100;
        } else {
            $year = 1900;
        }
        $year += _get_index($Oy, @d);
        if (not defined $struct->{C}) {
            require Time::C;
            if ($year < (Time::C->now_utc()->year - 50)) { $year += 100; }
        }
    }

    return ($year, $wyear);
}

fun _get_wday($struct, :$locale) {
    my $wday = $struct->{'u'} // $struct->{'w'};

    if (not defined $wday) {
        if (defined $struct->{'A'}) {
            $wday = _get_index($struct->{'A'}, @{ get_locale(weekdays => $locale) });
        } elsif (defined $struct->{'a'}) {
            $wday = _get_index($struct->{'a'}, @{ get_locale(weekdays_abbr => $locale) });
        }
    }
    if (not defined $wday) {
        if (defined(my $Ou = $struct->{Ou})) {
            my @d = @{ get_locale(digits => $locale) };
            $wday = _get_index($Ou, @d);
        } elsif (defined(my $Ow = $struct->{Ow})) {
            my @d = @{ get_locale(digits => $locale) };
            $wday = _get_index($Ow, @d);
        }
    }
    $wday = 7 if defined $wday and $wday == 0;

    return $wday;
}

fun _get_u_week ($struct, :$locale) {
    my $u_week = $struct->{U};

    if (not defined $u_week and defined(my $OU = $struct->{OU})) {
        my @d = @{ get_locale(digits => $locale) };
        $u_week = _get_index($OU, @d);
    }

    return $u_week;
}

fun _get_w_week ($struct, :$locale) {
    my $w_week = $struct->{W};

    if (not defined $w_week and defined(my $OW = $struct->{OW})) {
        my @d = @{ get_locale(digits => $locale) };
        $w_week = _get_index($OW, @d);
    }

    return $w_week;
}

fun _get_v_week ($struct, :$locale) {
    my $v_week = $struct->{V};

    if (not defined $v_week and defined(my $OV = $struct->{OV})) {
        my @d = @{ get_locale(digits => $locale) };
        $v_week = _get_index($OV, @d);
    }

    return $v_week;
}

fun _get_month ($struct, :$locale) {
    my $month = $struct->{'m'};
    if (not defined $month) {
        if (defined $struct->{'B'}) {
            $month = _get_index($struct->{'B'}, @{ get_locale(months => $locale) }) + 1;
        } elsif (defined $struct->{'b'}) {
            $month = _get_index($struct->{'b'}, @{ get_locale(months_abbr => $locale) }) + 1;
        }
    }
    if (not defined $month and defined(my $Om = $struct->{Om})) {
        my @d = @{ get_locale(digits => $locale) };
        $month = _get_index($Om, @d);
    }

    return $month;
}

fun _get_hour ($struct, :$locale) {
    my $hour = $struct->{'H'};
    if (not defined $hour) { $hour = $struct->{'k'}; }
    if (not defined $hour) {
        $hour = $struct->{'I'} // $struct->{'l'};
        if (defined $hour and length $struct->{'p'}) {
            if (_get_index($struct->{'p'}, @{ get_locale(am_pm => $locale) })) {
                # PM
                if ($hour < 12) { $hour += 12; }
            } else {
                # AM
                if ($hour == 12) { $hour = 0; }
            }
        }
    }

    if (not defined $hour and defined(my $OH = $struct->{OH})) {
        my @d = @{ get_locale(digits => $locale) };
        $hour = _get_index($OH, @d);
    } elsif (not defined $hour and defined(my $OI = $struct->{OI})) {
        my @d = @{ get_locale(digits => $locale) };
        $hour = _get_index($OI, @d);
        if (length $struct->{p}) {
            if (_get_index($struct->{p}, @{ get_locale(am_pm => $locale) })) {
                # PM
                if ($hour < 12) { $hour += 12; }
            } else {
                # AM
                if ($hour == 12) { $hour = 0; }
            }
        }
    }

    return $hour;
}

fun _get_minute ($struct, :$locale) {
    my $min = $struct->{'M'};

    if (not defined $min and defined(my $OM = $struct->{OM})) {
        my @d = @{ get_locale(digits => $locale) };
        $min = _get_index($OM, @d);
    }

    return $min;
}

fun _get_second ($struct, :$locale) {
    my $sec = $struct->{'S'};

    if (not defined $sec and defined(my $OS = $struct->{OS})) {
        my @d = @{ get_locale(digits => $locale) };
        $sec = _get_index($OS, @d);
    }

    return $sec;
}

fun _coerce_struct ($struct, $orig, :$locale) {
    # First, if we know the epoch, great
    my $epoch = $struct->{'s'};

    # Then set up as many date bits we know about
    #  year + day of year
    #  year + month + day of month
    #  year + week + day of week

    my ($year, $wyear) = _get_year($struct, locale => $locale);

    my $yday = $struct->{'j'};

    my $month = _get_month($struct, locale => $locale);

    my $mday = _get_mday($struct, locale => $locale);

    my $u_week = _get_u_week($struct, locale => $locale);
    my $w_week = _get_w_week($struct, locale => $locale);
    my $v_week = _get_v_week($struct, locale => $locale);

    my $wday = _get_wday($struct, locale => $locale);

    if (not defined $w_week and defined $u_week) {
        $w_week = $u_week;
        if (not defined $wday) { $wday = 7; } # if no wday defined, should set to first day of week, and since the u_week starts at sunday, wday = 7
        $w_week-- if $wday == 7;
    }

    if (not defined $v_week and defined $w_week) {
        if ($wyear) { croak "Can't strptime a %G/%g year with a %W/%U week"; }

        require Time::C;
        my $t = Time::C->new($year // $orig->{year} // Time::C->now_utc->year);
        $v_week = $w_week;
        if (($t->day_of_week > 1) and ($t->day_of_week < 5)) { $v_week++; }
    }

    if ($wyear and defined $v_week and $v_week > 1) {
        require Time::C;
        $year = Time::C->mktime(year => $year, week => $v_week)->year;
    } elsif (defined $v_week and $v_week > 1 and defined $year) {
        require Time::C;
        if (Time::C->mktime(year => $year, week => $v_week)->year == $year + 1) {
            $year-- if not defined $month;
        }
    } elsif (defined $v_week and $v_week > 1 and defined $orig->{year}) {
        require Time::C;
        if (Time::C->mktime(year => $orig->{year}, week => $v_week)->year == $orig->{year} + 1) {
            $year = $orig->{year} - 1 if not defined $month;
        }
    }

    # Next try to set up time bits -- these are pretty easy in comparison

    my $hour = _get_hour($struct, locale => $locale);

    my $min = _get_minute($struct, locale => $locale);

    my $sec = _get_second($struct, locale => $locale);

    # And last see if we have some timezone or at least offset info

    my $tz = $struct->{'Z'}; # should verify that it's a useful tz
    if (defined $tz) {
        require Time::C;
        undef $tz if not defined eval { Time::C->now($tz); };
    }

    my $offset = $struct->{'z'};

    my $offset_n = defined $offset ? _offset_to_minutes($offset) : undef;

    my %struct = ();

    $struct{second} = $sec if defined $sec;
    $struct{minute} = $min if defined $min;
    $struct{hour} = $hour if defined $hour;
    $struct{mday} = $mday if defined $mday;
    $struct{month} = $month if defined $month;
    $struct{week} = $v_week if defined $v_week;
    $struct{wday} = $wday if defined $wday;
    $struct{yday} = $yday if defined $yday;
    $struct{year} = $year if defined $year;
    $struct{epoch} = $epoch if defined $epoch;
    $struct{tz} = $tz if defined $tz;
    $struct{offset} = $offset_n if defined $offset_n;

    return %struct;
}

fun _offset_to_minutes ($offset) {
    my ($sign, $hours, $minutes) = $offset =~ m/^([+-])([0-9][0-9]):?([0-9][0-9])?$/;
    return $sign eq '+' ? ($hours * 60 + $minutes) : -($hours * 60 + $minutes);
}

fun _get_index ($needle, @haystack) {
    if (not @haystack and $needle eq '') { return 0; }

    foreach my $i (0 .. $#haystack) {
        return $i if $haystack[$i] eq $needle;
    }
    croak "Could not find $needle in the list.";
}

fun _get_eras ($type, $locale) {
    my @eras = @{ get_locale(era => $locale) };
    my @ret = map { my @fields = split /:/; $type eq 'period' ? $fields[4] : $fields[5] } @eras;

    return @ret;
}

1;

__END__