File Coverage

blib/lib/DateTime/Set.pm

Criterion	Covered	Total	%
statement	305	337	90.5
branch	124	166	74.7
condition	15	30	50.0
subroutine	53	57	92.9
pod	29	29	100.0
total	526	619	84.9

package DateTime::Set;

use strict;
use Carp;
use Params::Validate qw( validate SCALAR BOOLEAN OBJECT CODEREF ARRAYREF );
use DateTime 0.12;  # this is for version checking only
use DateTime::Duration;
use DateTime::Span;
use Set::Infinite 0.59;
use Set::Infinite::_recurrence;

use vars qw( $VERSION );

use constant INFINITY     =>       100 ** 100 ** 100 ;
use constant NEG_INFINITY => -1 * (100 ** 100 ** 100);

BEGIN {
    $VERSION = '0.3700';
}


sub _fix_datetime {
    # internal function -
    # (not a class method)
    #
    # checks that the parameter is an object, and
    # also protects the object against mutation

    return $_[0]
        unless defined $_[0];      # error
    return $_[0]->clone
        if ref( $_[0] );           # "immutable" datetime
    return DateTime::Infinite::Future->new
        if $_[0] == INFINITY;      # Inf
    return DateTime::Infinite::Past->new
        if $_[0] == NEG_INFINITY;  # -Inf
    return $_[0];                  # error
}

sub _fix_return_datetime {
    my ( $dt, $dt_arg ) = @_;

    # internal function -
    # (not a class method)
    #
    # checks that the returned datetime has the same
    # time zone as the parameter

    # TODO: set locale

    return unless $dt;
    return unless $dt_arg;
    if ( $dt_arg->can('time_zone_long_name') &&
         !( $dt_arg->time_zone_long_name eq 'floating' ) )
    {
        $dt->set_time_zone( $dt_arg->time_zone );
    }
    return $dt;
}

sub iterate {
    # deprecated method - use map() or grep() instead
    my ( $self, $callback ) = @_;
    my $class = ref( $self );
    my $return = $class->empty_set;
    $return->{set} = $self->{set}->iterate(
        sub {
            my $min = $_[0]->min;
            $callback->( $min->clone ) if ref($min);
        }
    );
    $return;
}

sub map {
    my ( $self, $callback ) = @_;
    my $class = ref( $self );
    die "The callback parameter to map() must be a subroutine reference"
        unless ref( $callback ) eq 'CODE';
    my $return = $class->empty_set;
    $return->{set} = $self->{set}->iterate(
        sub {
            local $_ = $_[0]->min;
            next unless ref( $_ );
            $_ = $_->clone;
            my @list = $callback->();
            my $set = Set::Infinite::_recurrence->new();
            $set = $set->union( $_ ) for @list;
            return $set;
        }
    );
    $return;
}

sub grep {
    my ( $self, $callback ) = @_;
    my $class = ref( $self );
    die "The callback parameter to grep() must be a subroutine reference"
        unless ref( $callback ) eq 'CODE';
    my $return = $class->empty_set;
    $return->{set} = $self->{set}->iterate(
        sub {
            local $_ = $_[0]->min;
            next unless ref( $_ );
            $_ = $_->clone;
            my $result = $callback->();
            return $_ if $result;
            return;
        }
    );
    $return;
}

sub add { return shift->add_duration( DateTime::Duration->new(@_) ) }

sub subtract { return shift->subtract_duration( DateTime::Duration->new(@_) ) }

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

sub add_duration {
    my ( $self, $dur ) = @_;
    $dur = $dur->clone;  # $dur must be "immutable"

    $self->{set} = $self->{set}->iterate(
        sub {
            my $min = $_[0]->min;
            $min->clone->add_duration( $dur ) if ref($min);
        },
        backtrack_callback => sub {
            my ( $min, $max ) = ( $_[0]->min, $_[0]->max );
            if ( ref($min) )
            {
                $min = $min->clone;
                $min->subtract_duration( $dur );
            }
            if ( ref($max) )
            {
                $max = $max->clone;
                $max->subtract_duration( $dur );
            }
            return Set::Infinite::_recurrence->new( $min, $max );
        },
    );
    $self;
}

sub set_time_zone {
    my ( $self, $tz ) = @_;

    $self->{set} = $self->{set}->iterate(
        sub {
            my $min = $_[0]->min;
            $min->clone->set_time_zone( $tz ) if ref($min);
        },
        backtrack_callback => sub {
            my ( $min, $max ) = ( $_[0]->min, $_[0]->max );
            if ( ref($min) )
            {
                $min = $min->clone;
                $min->set_time_zone( $tz );
            }
            if ( ref($max) )
            {
                $max = $max->clone;
                $max->set_time_zone( $tz );
            }
            return Set::Infinite::_recurrence->new( $min, $max );
        },
    );
    $self;
}

sub set {
    my $self = shift;
    my %args = validate( @_,
                         { locale => { type => SCALAR | OBJECT,
                                       default => undef },
                         }
                       );
    $self->{set} = $self->{set}->iterate(
        sub {
            my $min = $_[0]->min;
            $min->clone->set( %args ) if ref($min);
        },
    );
    $self;
}

sub from_recurrence {
    my $class = shift;

    my %args = @_;
    my %param;

    # Parameter renaming, such that we can use either
    #   recurrence => xxx   or   next => xxx, previous => xxx
    $param{next} = delete $args{recurrence} || delete $args{next};
    $param{previous} = delete $args{previous};

    $param{span} = delete $args{span};
    # they might be specifying a span using start / end
    $param{span} = DateTime::Span->new( %args ) if keys %args;

    my $self = {};

    die "Not enough arguments in from_recurrence()"
        unless $param{next} || $param{previous};

    if ( ! $param{previous} )
    {
        my $data = {};
        $param{previous} =
                sub {
                    _callback_previous ( _fix_datetime( $_[0] ), $param{next}, $data );
                }
    }
    else
    {
        my $previous = $param{previous};
        $param{previous} =
                sub {
                    $previous->( _fix_datetime( $_[0] ) );
                }
    }

    if ( ! $param{next} )
    {
        my $data = {};
        $param{next} =
                sub {
                    _callback_next ( _fix_datetime( $_[0] ), $param{previous}, $data );
                }
    }
    else
    {
        my $next = $param{next};
        $param{next} =
                sub {
                    $next->( _fix_datetime( $_[0] ) );
                }
    }

    my ( $min, $max );
    $max = $param{previous}->( DateTime::Infinite::Future->new );
    $min = $param{next}->( DateTime::Infinite::Past->new );
    $max = INFINITY if $max->is_infinite;
    $min = NEG_INFINITY if $min->is_infinite;

    my $base_set = Set::Infinite::_recurrence->new( $min, $max );
    $base_set = $base_set->intersection( $param{span}->{set} )
         if $param{span};

    # warn "base set is $base_set\n";

    my $data = {};
    $self->{set} =
            $base_set->_recurrence(
                $param{next},
                $param{previous},
                $data,
        );
    bless $self, $class;

    return $self;
}

sub from_datetimes {
    my $class = shift;
    my %args = validate( @_,
                         { dates =>
                           { type => ARRAYREF,
                           },
                         }
                       );
    my $self = {};
    $self->{set} = Set::Infinite::_recurrence->new;
    # possible optimization: sort datetimes and use "push"
    for( @{ $args{dates} } )
    {
        # DateTime::Infinite objects are not welcome here,
        # but this is not enforced (it does't hurt)

        carp "The 'dates' argument to from_datetimes() must only contain ".
             "datetime objects"
            unless UNIVERSAL::can( $_, 'utc_rd_values' );

        $self->{set} = $self->{set}->union( $_->clone );
    }

    bless $self, $class;
    return $self;
}

sub empty_set {
    my $class = shift;

    return bless { set => Set::Infinite::_recurrence->new }, $class;
}

sub is_empty_set {
    my $set = $_[0];
    $set->{set}->is_null;
}

sub clone {
    my $self = bless { %{ $_[0] } }, ref $_[0];
    $self->{set} = $_[0]->{set}->copy;
    return $self;
}

# default callback that returns the
# "previous" value in a callback recurrence.
#
# This is used to simulate a 'previous' callback,
# when then 'previous' argument in 'from_recurrence' is missing.
#
sub _callback_previous {
    my ($value, $callback_next, $callback_info) = @_;
    my $previous = $value->clone;

    return $value if $value->is_infinite;

    my $freq = $callback_info->{freq};
    unless (defined $freq)
    {
        # This is called just once, to setup the recurrence frequency
        my $previous = $callback_next->( $value );
        my $next =     $callback_next->( $previous );
        $freq = 2 * ( $previous - $next );
        # save it for future use with this same recurrence
        $callback_info->{freq} = $freq;
    }

    $previous->add_duration( $freq );
    $previous = $callback_next->( $previous );
    if ($previous >= $value)
    {
        # This error happens if the event frequency oscillates widely
        # (more than 100% of difference from one interval to next)
        my @freq = $freq->deltas;
        print STDERR "_callback_previous: Delta components are: @freq\n";
        warn "_callback_previous: iterator can't find a previous value, got ".
            $previous->ymd." after ".$value->ymd;
    }
    my $previous1;
    while (1)
    {
        $previous1 = $previous->clone;
        $previous = $callback_next->( $previous );
        return $previous1 if $previous >= $value;
    }
}

# default callback that returns the
# "next" value in a callback recurrence.
#
# This is used to simulate a 'next' callback,
# when then 'next' argument in 'from_recurrence' is missing.
#
sub _callback_next {
    my ($value, $callback_previous, $callback_info) = @_;
    my $next = $value->clone;

    return $value if $value->is_infinite;

    my $freq = $callback_info->{freq};
    unless (defined $freq)
    {
        # This is called just once, to setup the recurrence frequency
        my $next =     $callback_previous->( $value );
        my $previous = $callback_previous->( $next );
        $freq = 2 * ( $next - $previous );
        # save it for future use with this same recurrence
        $callback_info->{freq} = $freq;
    }

    $next->add_duration( $freq );
    $next = $callback_previous->( $next );
    if ($next <= $value)
    {
        # This error happens if the event frequency oscillates widely
        # (more than 100% of difference from one interval to next)
        my @freq = $freq->deltas;
        print STDERR "_callback_next: Delta components are: @freq\n";
        warn "_callback_next: iterator can't find a previous value, got ".
            $next->ymd." before ".$value->ymd;
    }
    my $next1;
    while (1)
    {
        $next1 = $next->clone;
        $next =  $callback_previous->( $next );
        return $next1 if $next >= $value;
    }
}

sub iterator {
    my $self = shift;

    my %args = @_;
    my $span;
    $span = delete $args{span};
    $span = DateTime::Span->new( %args ) if %args;

    return $self->intersection( $span ) if $span;
    return $self->clone;
}


# next() gets the next element from an iterator()
# next( $dt ) returns the next element after a datetime.
sub next {
    my $self = shift;
    return undef unless ref( $self->{set} );

    if ( @_ )
    {
        if ( $self->{set}->_is_recurrence )
        {
            return _fix_return_datetime(
                       $self->{set}->{param}[0]->( $_[0] ), $_[0] );
        }
        else
        {
            my $span = DateTime::Span->from_datetimes( after => $_[0] );
            return _fix_return_datetime(
                        $self->intersection( $span )->next, $_[0] );
        }
    }

    my ($head, $tail) = $self->{set}->first;
    $self->{set} = $tail;
    return $head->min if defined $head;
    return $head;
}

# previous() gets the last element from an iterator()
# previous( $dt ) returns the previous element before a datetime.
sub previous {
    my $self = shift;
    return undef unless ref( $self->{set} );

    if ( @_ )
    {
        if ( $self->{set}->_is_recurrence )
        {
            return _fix_return_datetime(
                      $self->{set}->{param}[1]->( $_[0] ), $_[0] );
        }
        else
        {
            my $span = DateTime::Span->from_datetimes( before => $_[0] );
            return _fix_return_datetime(
                      $self->intersection( $span )->previous, $_[0] );
        }
    }

    my ($head, $tail) = $self->{set}->last;
    $self->{set} = $tail;
    return $head->max if defined $head;
    return $head;
}

# "current" means less-or-equal to a datetime
sub current {
    my $self = shift;

    return undef unless ref( $self->{set} );

    if ( $self->{set}->_is_recurrence )
    {
        my $tmp = $self->next( $_[0] );
        return $self->previous( $tmp );
    }

    return $_[0] if $self->contains( $_[0] );
    $self->previous( $_[0] );
}

sub closest {
    my $self = shift;
    # return $_[0] if $self->contains( $_[0] );
    my $dt1 = $self->current( $_[0] );
    my $dt2 = $self->next( $_[0] );

    return $dt2 unless defined $dt1;
    return $dt1 unless defined $dt2;

    my $delta = $_[0] - $dt1;
    return $dt1 if ( $dt2 - $delta ) >= $_[0];

    return $dt2;
}

sub as_list {
    my $self = shift;
    return undef unless ref( $self->{set} );

    my %args = @_;
    my $span;
    $span = delete $args{span};
    $span = DateTime::Span->new( %args ) if %args;

    my $set = $self->clone;
    $set = $set->intersection( $span ) if $span;

    return if $set->{set}->is_null;  # nothing = empty

    # Note: removing this line means we may end up in an infinite loop!
    ## return undef if $set->{set}->is_too_complex;  # undef = no start/end

    return undef
        if $set->max->is_infinite ||
           $set->min->is_infinite;

    my @result;
    my $next = $self->min;
    if ( $span ) {
        my $next1 = $span->min;
        $next = $next1 if $next1 && $next1 > $next;
        $next = $self->current( $next );
    }
    my $last = $self->max;
    if ( $span ) {
        my $last1 = $span->max;
        $last = $last1 if $last1 && $last1 < $last;
    }
    do {
        push @result, $next if !$span || $span->contains($next);
        $next = $self->next( $next );
    }
    while $next && $next <= $last;
    return @result;
}

sub intersection {
    my ($set1, $set2) = ( shift, shift );
    my $class = ref($set1);
    my $tmp = $class->empty_set();
    $set2 = $set2->as_set
        if $set2->can( 'as_set' );
    $set2 = $class->from_datetimes( dates => [ $set2, @_ ] )
        unless $set2->can( 'union' );
    $tmp->{set} = $set1->{set}->intersection( $set2->{set} );
    return $tmp;
}

sub intersects {
    my ($set1, $set2) = ( shift, shift );
    my $class = ref($set1);
    $set2 = $set2->as_set
        if $set2->can( 'as_set' );
    unless ( $set2->can( 'union' ) )
    {
        if ( $set1->{set}->_is_recurrence )
        {
            for ( $set2, @_ )
            {
                return 1 if $set1->current( $_ ) == $_;
            }
            return 0;
        }
        $set2 = $class->from_datetimes( dates => [ $set2, @_ ] )
    }
    return $set1->{set}->intersects( $set2->{set} );
}

sub contains {
    my ($set1, $set2) = ( shift, shift );
    my $class = ref($set1);
    $set2 = $set2->as_set
        if $set2->can( 'as_set' );
    unless ( $set2->can( 'union' ) )
    {
        if ( $set1->{set}->_is_recurrence )
        {
            for ( $set2, @_ )
            {
                return 0 unless $set1->current( $_ ) == $_;
            }
            return 1;
        }
        $set2 = $class->from_datetimes( dates => [ $set2, @_ ] )
    }
    return $set1->{set}->contains( $set2->{set} );
}

sub union {
    my ($set1, $set2) = ( shift, shift );
    my $class = ref($set1);
    my $tmp = $class->empty_set();
    $set2 = $set2->as_set
        if $set2->can( 'as_set' );
    $set2 = $class->from_datetimes( dates => [ $set2, @_ ] )
        unless $set2->can( 'union' );
    $tmp->{set} = $set1->{set}->union( $set2->{set} );
    bless $tmp, 'DateTime::SpanSet'
        if $set2->isa('DateTime::Span') or $set2->isa('DateTime::SpanSet');
    return $tmp;
}

sub complement {
    my ($set1, $set2) = ( shift, shift );
    my $class = ref($set1);
    my $tmp = $class->empty_set();
    if (defined $set2)
    {
        $set2 = $set2->as_set
            if $set2->can( 'as_set' );
        $set2 = $class->from_datetimes( dates => [ $set2, @_ ] )
            unless $set2->can( 'union' );
        # TODO: "compose complement";
        $tmp->{set} = $set1->{set}->complement( $set2->{set} );
    }
    else
    {
        $tmp->{set} = $set1->{set}->complement;
        bless $tmp, 'DateTime::SpanSet';
    }
    return $tmp;
}

sub start {
    return _fix_datetime( $_[0]->{set}->min );
}

*min = \&start;

sub end {
    return _fix_datetime( $_[0]->{set}->max );
}

*max = \&end;

# returns a DateTime::Span
sub span {
  my $set = $_[0]->{set}->span;
  my $self = bless { set => $set }, 'DateTime::Span';
  return $self;
}

sub count {
    my ($self) = shift;
    return undef unless ref( $self->{set} );

    my %args = @_;
    my $span;
    $span = delete $args{span};
    $span = DateTime::Span->new( %args ) if %args;

    my $set = $self->clone;
    $set = $set->intersection( $span ) if $span;

    return $set->{set}->count
        unless $set->{set}->is_too_complex;

    return undef
        if $set->max->is_infinite ||
           $set->min->is_infinite;

    my $count = 0;
    my $iter = $set->iterator;
    $count++ while $iter->next;
    return $count;
}

1;

__END__