File Coverage

lib/DR/DateTime.pm

Criterion	Covered	Total	%
statement	220	242	90.9
branch	62	78	79.4
condition	24	36	66.6
subroutine	44	51	86.2
pod	20	27	74.0
total	370	434	85.2

package DR::DateTime;
use DR::DateTime::Defaults;

use 5.010001;
use strict;
use warnings;
our $VERSION = '1.00';
use Carp;

use POSIX ();
use Time::Local ();
use Time::Zone ();
use feature 'state';

sub TO_JSON { shift->strftime('%F %T%z') }  # JSON::XS compatible

use overload
        'bool'      => sub { 1 },
        '""'        => sub { shift->strftime('%F %T%z') },
        '<=>'       => sub {
            my ($self, $cv, $flip) = @_;
            if ('DR::DateTime' eq ref $cv) {
                return $self->fepoch <=> $cv->fepoch;
            }
            return $self->fepoch <=> $cv;
        },

        'cmp'       => sub {
            my ($self, $cv, $flip) = @_;
            if ('DR::DateTime' eq ref $cv) {
                return $self->strftime('%F %T%z') cmp $cv->strftime('%F %T%z');
            }
            my $pct = $self->parse($cv);
            return $self->strftime('%F %T%z') cmp $cv unless $pct;
            return $self->strftime('%F %T%z') cmp $pct->strftime('%F %T%z');
        },

        int         => sub { shift->epoch },

        '+'         => sub {
            my ($self, $cv, $flip) = @_;
            if ('DR::DateTime' eq ref $cv) {
                return $self->new(
                    $self->fepoch + $cv->fepoch,
                    $self->[1]
                )
            }

            $self->new(
                $self->fepoch + $cv,
                $self->[1]
            )
        },

        '-'         => sub {
            my ($self, $cv, $flip) = @_;

            if ($flip) {
                if ('DR::DateTime' eq ref $cv) {
                    return $cv->fepoch - $self->fepoch;
                }
                return $cv - $self->fepoch;
            } else {
                if ('DR::DateTime' eq ref $cv) { # date1 - $date2
                    return $self->fepoch - $cv->fepoch;
                }
                return $self->new($self->fepoch - $cv, $self->[1]);
            }
        }
;


sub new {
    my ($class, $stamp, $tz) = @_;
    $stamp //= time;

    if (defined $tz) {
        $tz =~ /^([+-])?(\d{2})(\d{2})?$/;
        croak "Wrong timezone format" unless defined $2;

        $tz = join '',
                $1 // '+',
                $2,
                $3 // '00';
    }

    $tz = $DR::DateTime::Defaults::TZFORCE
        if defined $DR::DateTime::Defaults::TZFORCE;

    bless [ $stamp, $tz // () ] => ref($class) || $class;
}

sub parse {
    my ($class, $str, $default_tz, $nocheck) = @_;
    return undef unless defined $str;
    my ($y, $m, $d, $H, $M, $S, $ns, $z);

    for ($str) {

        if (/^\d+$/) {
            return $class->new($str, $default_tz // '+0000');
        }
        if (/^(\d{4})-(\d{2})-(\d{2})(?:\s+|T)(\d{2}):(\d{2}):(\d{2})(\.\d+)?\s*(\S+)?$/) {
            ($y, $m, $d, $H, $M, $S, $ns, $z) =
                ($1, $2, $3, $4, $5, $6, $7, $8);
            goto PARSED;
        }

        if (/^(\d{4})-(\d{2})-(\d{2})(?:\s+|T)(\d{2}):(\d{2})$/) {
            ($y, $m, $d, $H, $M, $S, $ns, $z) =
                ($1, $2, $3, $4, $5, 0, 0, undef);
            goto PARSED;
        }

        if (/^(\d{4})-(\d{2})-(\d{2})$/) {
            ($y, $m, $d, $H, $M, $S, $ns, $z) =
                ($1, $2, $3, 0, 0, 0, 0, undef);
            goto PARSED;
        }

        if (/^(\d{1,2})\.(\d{1,2})\.(\d{4})\s+(\d{2}):(\d{2}):(\d{2})(\.\d+)?\s*(\S+)?$/) {
            ($y, $m, $d, $H, $M, $S, $ns, $z) =
                ($3, $2, $1, $4, $5, $6, $7, $8);
            goto PARSED;
        }

        return undef;
    }


    PARSED:

        $z //= $default_tz // '+0000';
        for ($z) {
            if (/^[+-]\d{1,4}$/) {
                s/^([+-])(\d|\d{3})$/${1}0$2/;
                s/^([+-])(\d{2})$/${1}${2}00/;
            } else {
                croak "Wrong time zone format: '$z'";
            }
        }
        for ($m) {
            s/^0//;
            $_--;
        }
        for ($d, $H, $M, $S) {
            s/^0//;
        }
        $y -= 1900;

        $ns //= 0;
        my $stamp = eval {
            local $SIG{__DIE__} = sub {}; # Ick!
            return Time::Local::timegm_nocheck($S,$M,$H,$d,$m,$y) if $nocheck;
            Time::Local::timegm($S,$M,$H,$d,$m,$y);
        };
        $stamp += $ns;

        my $offset = Time::Zone::tz_offset($z, $stamp);
        $class->new($stamp - $offset, $z);
}

sub fepoch  { shift->[0] }
sub epoch   { POSIX::floor(shift->[0]) }
sub tz      { shift->[1] // $DR::DateTime::Defaults::TZ }

sub strftime :method {
    my ($self, $format) = @_;
    croak 'Invalid format' unless $format;
    my $offset = Time::Zone::tz_offset($self->tz, $self->epoch);
    my $stamp = $self->epoch + $offset;
    my $fstamp = $self->fepoch + $offset;

    state $patterns;
    unless ($patterns) {
        $patterns = {
            '%'     => sub { '%' },
            'z'     => sub { shift->tz },
            'Z'     => sub { shift->tz },
            'N'     => sub {
                int(1_000_000_000 * abs($_[2] - $_[1])) }

        };
        for my $sp (split //, 'aAbBcCdDeEFgGhHIjklmMnOpPrRsStTuUVwWxXyY') {
            $patterns->{$sp} = sub { POSIX::strftime "%$sp", gmtime $_[1] }
        }
    }

    $format =~ s{%([a-zA-Z%])}
        { $patterns->{$1} ? $patterns->{$1}->($self, $stamp, $fstamp) : "%$1" }sgex;

    $format;
}


sub year { shift->strftime('%Y') }

sub month {
    for my $m (shift->strftime('%m')) {
        $m =~ s/^0//;
        return $m;
    }
}

sub day {
    for my $d (shift->strftime('%d')) {
        $d =~ s/^0//;
        return $d;
    }
}

sub day_of_week { shift->strftime('%u') }

sub quarter { POSIX::ceil(shift->month / 3) }

sub hour {
    for my $h (shift->strftime('%H')) {
        $h =~ s/^0//;
        return $h;
    }
}

sub minute {
    for my $m (shift->strftime('%M')) {
        $m =~ s/^0//;
        return $m;
    }
}
sub second {
    for my $s (shift->strftime('%S')) {
        $s =~ s/^0//;
        return $s;
    }
}

sub nanosecond { shift->strftime('%N') }

sub hms {
    my ($self, $sep) = @_;
    $sep //= ':';
    for ($sep) {
        s/%/%%/g;
    }
    $self->strftime("%H$sep%M$sep%S");
}

sub datetime {
    my ($self) = @_;
    return join 'T', $self->ymd, $self->hms;
}

sub ymd {
    my ($self, $sep) = @_;
    $sep //= ':';
    for ($sep) {
        s/%/%%/g;
    }
    $self->strftime("%Y$sep%m$sep%d");
}

sub time_zone { goto \&tz   }
sub hires_epoch { goto \&fepoch }
sub _fix_date_after_arith_month {
    my ($self, $new) = @_;
    return $new->fepoch if $self->day == $new->day;
    if ($new->day < $self->day) {
        $new->[0] -= 86400;
    }
    $new->fepoch;
}
sub add {
    my ($self, %set) = @_;

    for my $n (delete $set{nanosecond}) {
        last unless defined $n;
        $self->[0] += $n / 1_000_000_000;
    }

    for my $s (delete $set{second}) {
        last unless defined $s;
        $self->[0] += $s;
    }

    for my $m (delete $set{minute}) {
        last unless defined $m;
        $self->[0] += $m * 60;
    }

    for my $h (delete $set{hour}) {
        last unless defined $h;
        $self->[0] += $h * 3600;
    }

    for my $d (delete $set{day}) {
        last unless defined $d;
        $self->[0] += $d * 86400;
    }

    for my $m (delete $set{month}) {
        last unless defined $m;
        my $nm = $self->month + $m;

        $set{year} //= 0;
        while ($nm > 12) {
            $nm -= 12;
            $set{year}++;
        }

        while ($nm < 1) {
            $nm += 12;
            $set{year}--;
        }
        my $str = $self->strftime('%F %T.%N %z');
        $str =~ s/(\d{4})-\d{2}-/sprintf "%s-%02d-", $1, $nm/e;
        $self->[0] =
            $self->_fix_date_after_arith_month($self->parse($str, undef, 1));
    }

    for my $y (delete $set{year}) {
        last unless defined $y;
        $y += $self->year;
        my $str = $self->strftime('%F %T.%N %z');
        $str =~ s/^\d{4}/$y/;
        $self->[0] =
            $self->_fix_date_after_arith_month($self->parse($str, undef, 1));
    }
    $self;
}

sub subtract {
    my ($self, %set) = @_;

    my %sub;
    while (my ($k, $v) = each %set) {
        $sub{$k} = -$v;
    }
    $self->add(%sub);
}

sub truncate {
    my ($self, %opts) = @_;

    my $to = $opts{to} // 'second';

    if ($to eq 'second') {
        $self->[0] = $self->epoch;
        return $self;
    }

    my $str;
    if ($to eq 'minute') {
        $str = $self->strftime('%F %H:%M:00%z');
        goto PARSE;
    }

    if ($to eq 'hour') {
        $str = $self->strftime('%F %H:00:00%z');
        goto PARSE;
    }

    if ($to eq 'day') {
        $str = $self->strftime('%F 00:00:00%z');
        goto PARSE;
    }

    if ($to eq 'month') {
        $str = $self->strftime('%Y-%m-01 00:00:00%z');
        goto PARSE;
    }

    if ($to eq 'year') {
        $str = $self->strftime('%Y-01-01 00:00:00%z');
        goto PARSE;
    }

    croak "Can not truncate the datetime to '$to'";

    PARSE:
        $self->[0] = $self->parse($str)->epoch;
        $self;
}

sub clone {
    my ($self) = @_;
    bless [ @$self ] => ref($self) || $self;
}

sub set_time_zone {
    my ($self, $tz) = @_;
    if (defined $tz) {
        for ($tz) {
            s/^\d{1,4}$/+$&/;
            s/^([+-])(\d)$/${1}0${2}00/;
            s/^([+-]\d{2})$/${1}00/;
            s/^([+-])(\d{3})$/${1}0$2/;
        }

        if ($tz eq 'local') {
            $tz = undef;
        } elsif ($tz !~ /^[+-]\d{4}$/) {
            croak "Wrong time zone: '$tz'";
        }
    }
    $self->[1] = $tz;
    $self;
}

sub set_tz { goto \&set_time_zone }

1;

__END__