File Coverage

blib/lib/DateTimeX/Lite/Duration.pm

Criterion	Covered	Total	%
statement	141	144	97.9
branch	55	60	91.6
condition	10	15	66.6
subroutine	45	46	97.8
pod	33	33	100.0
total	284	298	95.3

package DateTimeX::Lite::Duration;
use strict;
use warnings;
use Scalar::Util qw(blessed);

use Carp ();

use overload ( fallback => 1,
               '+'   => '_add_overload',
               '-'   => '_subtract_overload',
               '*'   => '_multiply_overload',
               '<=>' => '_compare_overload',
               'cmp' => '_compare_overload',
             );

use constant MAX_NANOSECONDS => 1_000_000_000;  # 1E9 = almost 32 bits

my @all_units = qw( months days minutes seconds nanoseconds );

# XXX - need to reject non-integers but accept infinity, NaN, &
# 1.56e+18
sub new
{
    my ($class, %p) = @_;
    foreach my $field (qw(years months weeks days hours minutes seconds nanoseconds)) {
        $p{$field} = 0 unless defined $p{$field};
    }

=head1
    my %p = validate( @_,
                         { years   => { type => SCALAR, default => 0 },
                           months  => { type => SCALAR, default => 0 },
                           weeks   => { type => SCALAR, default => 0 },
                           days    => { type => SCALAR, default => 0 },
                           hours   => { type => SCALAR, default => 0 },
                           minutes => { type => SCALAR, default => 0 },
                           seconds => { type => SCALAR, default => 0 },
                           nanoseconds => { type => SCALAR, default => 0 },
                           end_of_month => { type => SCALAR, default => undef,
                                             regex => qr/^(?:wrap|limit|preserve)$/ },
                         } );
=cut

    my $self = bless {}, $class;

    $self->{months} = ( $p{years} * 12 ) + $p{months};

    $self->{days} = ( $p{weeks} * 7 ) + $p{days};

    $self->{minutes} = ( $p{hours} * 60 ) + $p{minutes};

    $self->{seconds} = $p{seconds};

    if ( $p{nanoseconds} )
    {
        $self->{nanoseconds} = $p{nanoseconds};
        $self->_normalize_nanoseconds;
    }
    else
    {
        # shortcut - if they don't need nanoseconds
        $self->{nanoseconds} = 0;
    }

    $self->{end_of_month} =
        ( defined $p{end_of_month}
          ? $p{end_of_month}
          : $self->{months} < 0
          ? 'preserve'
          : 'wrap'
        );

    return $self;
}

# make the signs of seconds, nanos the same; 0 < abs(nanos) < MAX_NANOS
# NB this requires nanoseconds != 0 (callers check this already)
sub _normalize_nanoseconds
{
    my $self = shift;

    return if
        ( $self->{nanoseconds} == DateTimeX::Lite::INFINITY()
          || $self->{nanoseconds} == DateTimeX::Lite::NEG_INFINITY()
          || $self->{nanoseconds} eq DateTimeX::Lite::NAN()
        );

    my $seconds = $self->{seconds} + $self->{nanoseconds} / MAX_NANOSECONDS;
    $self->{seconds} = int( $seconds );
    $self->{nanoseconds} = $self->{nanoseconds} % MAX_NANOSECONDS;
    $self->{nanoseconds} -= MAX_NANOSECONDS if $seconds < 0;
}

sub clone { bless { %{ $_[0] } }, ref $_[0] }

sub years   { abs( $_[0]->in_units( 'years' ) ) }
sub months  { abs( $_[0]->in_units( 'months', 'years' ) ) }
sub weeks   { abs( $_[0]->in_units( 'weeks' ) ) }
sub days    { abs( $_[0]->in_units( 'days', 'weeks' ) ) }
sub hours   { abs( $_[0]->in_units( 'hours' ) ) }
sub minutes { abs( $_[0]->in_units( 'minutes', 'hours' ) ) }
sub seconds { abs( $_[0]->in_units( 'seconds' ) ) }
sub nanoseconds { abs( $_[0]->in_units( 'nanoseconds', 'seconds' ) ) }

sub is_positive {   $_[0]->_has_positive && ! $_[0]->_has_negative }
sub is_negative { ! $_[0]->_has_positive &&   $_[0]->_has_negative }

sub _has_positive { ( grep { $_ > 0 } @{ $_[0] }{@all_units} ) ? 1 : 0}
sub _has_negative { ( grep { $_ < 0 } @{ $_[0] }{@all_units} ) ? 1 : 0 }

sub is_zero       { return 0 if grep { $_ != 0 } @{ $_[0] }{@all_units};
                    return 1 }

sub delta_months  { $_[0]->{months} }
sub delta_days    { $_[0]->{days} }
sub delta_minutes { $_[0]->{minutes} }
sub delta_seconds { $_[0]->{seconds} }
sub delta_nanoseconds { $_[0]->{nanoseconds} }

sub deltas
{
    map { $_ => $_[0]->{$_} } @all_units;
}

sub in_units
{
    my $self  = shift;
    my @units = @_;

    my %units = map { $_ => 1 } @units;

    my %ret;

    my ( $months, $days, $minutes, $seconds ) =
        @{ $self }{qw( months days minutes seconds )};

    if ( $units{years} )
    {
        $ret{years} = int( $months / 12 );
        $months -= $ret{years} * 12;
    }

    if ( $units{months} )
    {
        $ret{months} = $months;
    }

    if ( $units{weeks} )
    {
        $ret{weeks} = int( $days / 7 );
        $days -= $ret{weeks} * 7;
    }

    if ( $units{days} )
    {
        $ret{days} = $days;
    }

    if ( $units{hours} )
    {
        $ret{hours} = int( $minutes / 60 );
        $minutes -= $ret{hours} * 60;
    }

    if ( $units{minutes} )
    {
        $ret{minutes} = $minutes
    }

    if ( $units{seconds} )
    {
        $ret{seconds} = $seconds;
        $seconds = 0;
    }

    if ( $units{nanoseconds} )
    {
        $ret{nanoseconds} = $seconds * MAX_NANOSECONDS + $self->{nanoseconds};
    }

    wantarray ? @ret{@units} : $ret{ $units[0] };
}

sub is_wrap_mode     { $_[0]->{end_of_month} eq 'wrap'   ? 1 : 0 }
sub is_limit_mode    { $_[0]->{end_of_month} eq 'limit'  ? 1 : 0 }
sub is_preserve_mode { $_[0]->{end_of_month} eq 'preserve' ? 1 : 0 }

sub end_of_month_mode { $_[0]->{end_of_month} }

sub calendar_duration
{
    my $self = shift;

    return
        (ref $self)->new( map { $_ => $self->{$_} } qw( months days end_of_month ) )
}

sub clock_duration
{
    my $self = shift;

    return
        (ref $self)->new( map { $_ => $self->{$_} } qw( minutes seconds nanoseconds end_of_month ) )
}

sub inverse
{
    my $self = shift;

    my %new;
    foreach my $u (@all_units)
    {
        $new{$u} = $self->{$u};
        # avoid -0 bug
        $new{$u} *= -1 if $new{$u};
    }

    return (ref $self)->new(%new);
}

sub add_duration
{
    my ( $self, $dur ) = @_;

    foreach my $u (@all_units)
    {
        $self->{$u} += $dur->{$u};
    }

    $self->_normalize_nanoseconds if $self->{nanoseconds};

    return $self;
}

sub add
{
    my $self = shift;

    return $self->add_duration( (ref $self)->new(@_) );
}

sub subtract_duration { return $_[0]->add_duration( $_[1]->inverse ) }

sub subtract
{
    my $self = shift;

    return $self->subtract_duration( (ref $self)->new(@_) )
}

sub multiply
{
    my $self = shift;
    my $multiplier = shift;

    foreach my $u (@all_units)
    {
        $self->{$u} *= $multiplier;
    }

    $self->_normalize_nanoseconds if $self->{nanoseconds};

    return $self;
}

sub compare
{
    my ( $class, $dur1, $dur2, $dt ) = @_;

    $dt ||= DateTimeX::Lite->now;

    return
        DateTimeX::Lite->compare( $dt->clone->add_duration($dur1), $dt->clone->add_duration($dur2) );
}

sub _add_overload
{
    my ( $d1, $d2, $rev ) = @_;

    ($d1, $d2) = ($d2, $d1) if $rev;

    if ( blessed $d2 && $d2->isa( 'DateTimeX::Lite' ) )
    {
        $d2->add_duration($d1);
        return;
    }

    # will also work if $d1 is a DateTimeX::Lite.pm object
    return $d1->clone->add_duration($d2);
}

sub _subtract_overload
{
    my ( $d1, $d2, $rev ) = @_;

    ($d1, $d2) = ($d2, $d1) if $rev;

    Carp::croak( "Cannot subtract a DateTimeX::Lite object from a DateTimeX::Lite::Duration object" )
        if blessed $d2 && $d2->isa( 'DateTimeX::Lite' );

    return $d1->clone->subtract_duration($d2);
}

sub _multiply_overload
{
    my $self = shift;

    my $new = $self->clone;

    return $new->multiply(@_);
}

sub _compare_overload
{
    Carp::croak( 'DateTimeX::Lite::Duration does not overload comparison.'
                 . '  See the documentation on the compare() method for details.' );
}


1;

__END__