File Coverage

blib/lib/DateTime/SpanSet.pm

Criterion	Covered	Total	%
statement	222	282	78.7
branch	87	158	55.0
condition	14	33	42.4
subroutine	31	41	75.6
pod	28	28	100.0
total	382	542	70.4

# Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

package DateTime::SpanSet;

use strict;

use DateTime::Set;
use DateTime::Infinite;

use Carp;
use Params::Validate qw( validate SCALAR BOOLEAN OBJECT CODEREF ARRAYREF );
use vars qw( $VERSION );

use constant INFINITY     =>       100 ** 100 ** 100 ;
use constant NEG_INFINITY => -1 * (100 ** 100 ** 100);
$VERSION = $DateTime::Set::VERSION;

sub iterate {
    my ( $self, $callback ) = @_;
    my $class = ref( $self );
    my $return = $class->empty_set;
    $return->{set} = $self->{set}->iterate(
        sub {
            my $span = bless { set => $_[0] }, 'DateTime::Span';
            $callback->( $span->clone );
            $span = $span->{set}
                if UNIVERSAL::can( $span, 'union' );
            return $span;
        }
    );
    $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 $_ = bless { set => $_[0]->clone }, 'DateTime::Span';
            my @list = $callback->();
            my $set = $class->empty_set;
            $set = $set->union( $_ ) for @list;
            return $set->{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 $_ = bless { set => $_[0]->clone }, 'DateTime::Span';
            my $result = $callback->();
            return $_->{set} if $result && $_;
            return;
        }
    );
    $return;
}

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

    # TODO - use iterate() instead

    my $result = $self->{set}->iterate(
        sub {
            my %tmp = %{ $_[0]->{list}[0] };
            $tmp{a} = $tmp{a}->clone->set_time_zone( $tz ) if ref $tmp{a};
            $tmp{b} = $tmp{b}->clone->set_time_zone( $tz ) if ref $tmp{b};
            \%tmp;
        },
        backtrack_callback => sub {
            my ( $min, $max ) = ( $_[0]->min, $_[0]->max );
            if ( ref($min) )
            {
                $min = $min->clone;
                $min->set_time_zone( 'floating' );
            }
            if ( ref($max) )
            {
                $max = $max->clone;
                $max->set_time_zone( 'floating' );
            }
            return Set::Infinite::_recurrence->new( $min, $max );
        },
    );

    ### this code enables 'subroutine method' behaviour
    $self->{set} = $result;
    return $self;
}

sub from_spans {
    my $class = shift;
    my %args = validate( @_,
                         { spans =>
                           { type => ARRAYREF,
                             optional => 1,
                           },
                         }
                       );
    my $self = {};
    my $set = Set::Infinite::_recurrence->new();
    $set = $set->union( $_->{set} ) for @{ $args{spans} };
    $self->{set} = $set;
    bless $self, $class;
    return $self;
}

sub from_set_and_duration {
    # set => $dt_set, days => 1
    my $class = shift;
    my %args = @_;
    my $set = delete $args{set} ||
        carp "from_set_and_duration needs a 'set' parameter";

    $set = $set->as_set
        if UNIVERSAL::can( $set, 'as_set' );
    unless ( UNIVERSAL::can( $set, 'union' ) ) {
        carp "'set' must be a set" };

    my $duration = delete $args{duration} ||
                   new DateTime::Duration( %args );
    my $end_set = $set->clone->add_duration( $duration );
    return $class->from_sets( start_set => $set,
                              end_set =>   $end_set );
}

sub from_sets {
    my $class = shift;
    my %args = validate( @_,
                         { start_set =>
                           { # can => 'union',
                             optional => 0,
                           },
                           end_set =>
                           { # can => 'union',
                             optional => 0,
                           },
                         }
                       );
    my $start_set = delete $args{start_set};
    my $end_set   = delete $args{end_set};

    $start_set = $start_set->as_set
        if UNIVERSAL::can( $start_set, 'as_set' );
    $end_set = $end_set->as_set
        if UNIVERSAL::can( $end_set, 'as_set' );

    unless ( UNIVERSAL::can( $start_set, 'union' ) ) {
        carp "'start_set' must be a set" };
    unless ( UNIVERSAL::can( $end_set, 'union' ) ) {
        carp "'end_set' must be a set" };

    my $self;
    $self->{set} = $start_set->{set}->until(
                   $end_set->{set} );
    bless $self, $class;
    return $self;
}

sub start_set {
    if ( exists $_[0]->{set}{method} &&
         $_[0]->{set}{method} eq 'until' )
    {
        return bless { set => $_[0]->{set}{parent}[0] }, 'DateTime::Set';
    }
    my $return = DateTime::Set->empty_set;
    $return->{set} = $_[0]->{set}->start_set;
    $return;
}

sub end_set {
    if ( exists $_[0]->{set}{method} &&
         $_[0]->{set}{method} eq 'until' )
    {
        return bless { set => $_[0]->{set}{parent}[1] }, 'DateTime::Set';
    }
    my $return = DateTime::Set->empty_set;
    $return->{set} = $_[0]->{set}->end_set;
    $return;
}

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 {
    bless {
        set => $_[0]->{set}->copy,
        }, ref $_[0];
}


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()
sub next {
    my ($self) = shift;

    # TODO: this is fixing an error from elsewhere
    # - find out what's going on! (with "sunset.pl")
    return undef unless ref $self->{set};

    if ( @_ )
    {
        my $max;
        $max = $_[0]->max if UNIVERSAL::can( $_[0], 'union' );
        $max = $_[0] if ! defined $max;

        return undef if ! ref( $max ) && $max == INFINITY;

        my $span = DateTime::Span->from_datetimes( start => $max );
        my $iterator = $self->intersection( $span );
        my $return = $iterator->next;

        return $return if ! defined $return;
        return $return if ! $return->intersects( $max );

        return $iterator->next;
    }

    my ($head, $tail) = $self->{set}->first;
    $self->{set} = $tail;
    return $head unless ref $head;
    my $return = {
        set => $head,
    };
    bless $return, 'DateTime::Span';
    return $return;
}

# previous() gets the last element from an iterator()
sub previous {
    my ($self) = shift;

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

    if ( @_ )
    {
        my $min;
        $min = $_[0]->min if UNIVERSAL::can( $_[0], 'union' );
        $min = $_[0] if ! defined $min;

        return undef if ! ref( $min ) && $min == INFINITY;

        my $span = DateTime::Span->from_datetimes( end => $min );
        my $iterator = $self->intersection( $span );
        my $return = $iterator->previous;

        return $return if ! defined $return;
        return $return if ! $return->intersects( $min );

        return $iterator->previous;
    }

    my ($head, $tail) = $self->{set}->last;
    $self->{set} = $tail;
    return $head unless ref $head;
    my $return = {
        set => $head,
    };
    bless $return, 'DateTime::Span';
    return $return;
}

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

    my $previous;
    my $next;
    {
        my $min;
        $min = $_[0]->min if UNIVERSAL::can( $_[0], 'union' );
        $min = $_[0] if ! defined $min;
        return undef if ! ref( $min ) && $min == INFINITY;
        my $span = DateTime::Span->from_datetimes( end => $min );
        my $iterator = $self->intersection( $span );
        $previous = $iterator->previous;
        $span = DateTime::Span->from_datetimes( start => $min );
        $iterator = $self->intersection( $span );
        $next = $iterator->next;
    }
    return $previous unless defined $next;

    my $dt1 = defined $previous
        ? $next->union( $previous )
        : $next;

    my $return = $dt1->intersected_spans( $_[0] );

    $return = $previous
        if !defined $return->max;

    bless $return, 'DateTime::SpanSet'
        if defined $return;
    return $return;
}

sub closest {
    my $self = shift;
    my $dt = shift;

    my $dt1 = $self->current( $dt );
    my $dt2 = $self->next( $dt );
    bless $dt2, 'DateTime::SpanSet'
        if defined $dt2;

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

    $dt = DateTime::Set->from_datetimes( dates => [ $dt ] )
        unless UNIVERSAL::can( $dt, 'union' );

    return $dt1 if $dt1->contains( $dt );

    my $delta = $dt->min - $dt1->max;
    return $dt1 if ( $dt2->min - $delta ) >= $dt->max;

    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;

    # 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 if $set->{set}->is_null;  # nothing = empty
    my @result;
    # we should extract _copies_ of the set elements,
    # such that the user can't modify the set indirectly

    my $iter = $set->iterator;
    while ( my $dt = $iter->next )
    {
        push @result, $dt
            if ref( $dt );   # we don't want to return INFINITY value
    };

    return @result;
}

# Set::Infinite methods

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

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

sub intersects {
    my ($set1, $set2) = ( shift, shift );

    unless ( $set2->can( 'union' ) )
    {
        for ( $set2, @_ )
        {
            return 1 if $set1->contains( $_ );
        }
        return 0;
    }

    my $class = ref($set1);
    $set2 = $set2->as_spanset
        if $set2->can( 'as_spanset' );
    $set2 = $set2->as_set
        if $set2->can( 'as_set' );
    $set2 = DateTime::Set->from_datetimes( dates => [ $set2, @_ ] )
        unless $set2->can( 'union' );
    return $set1->{set}->intersects( $set2->{set} );
}

sub contains {
    my ($set1, $set2) = ( shift, shift );

    unless ( $set2->can( 'union' ) )
    {
        if ( exists $set1->{set}{method} &&
             $set1->{set}{method} eq 'until' )
        {
            my $start_set = $set1->start_set;
            my $end_set =   $set1->end_set;

            for ( $set2, @_ )
            {
                my $start = $start_set->next( $set2 );
                my $end =   $end_set->next( $set2 );

                goto ABORT unless defined $start && defined $end;

                return 0 if $start < $end;
            }
            return 1;

            ABORT: ;
            # don't know
        }
    }

    my $class = ref($set1);
    $set2 = $set2->as_spanset
        if $set2->can( 'as_spanset' );
    $set2 = $set2->as_set
        if $set2->can( 'as_set' );
    $set2 = DateTime::Set->from_datetimes( dates => [ $set2, @_ ] )
        unless $set2->can( 'union' );
    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_spanset
        if $set2->can( 'as_spanset' );
    $set2 = $set2->as_set
        if $set2->can( 'as_set' );
    $set2 = DateTime::Set->from_datetimes( dates => [ $set2, @_ ] )
        unless $set2->can( 'union' );
    $tmp->{set} = $set1->{set}->union( $set2->{set} );
    return $tmp;
}

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

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

*min = \&start;

sub end {
    return DateTime::Set::_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;
}

# returns a DateTime::Duration
sub duration {
    my $dur;

    return DateTime::Duration->new( seconds => 0 )
        if $_[0]->{set}->is_empty;

    local $@;
    eval {
        local $SIG{__DIE__};   # don't want to trap this (rt ticket 5434)
        $dur = $_[0]->{set}->size
    };

    return $dur if defined $dur && ref( $dur );
    return DateTime::Infinite::Future->new -
           DateTime::Infinite::Past->new;
    # return INFINITY;
}
*size = \&duration;

1;

__END__