File Coverage

blib/lib/DateTime/Event/Recurrence.pm

Criterion	Covered	Total	%
statement	293	300	97.6
branch	105	128	82.0
condition	33	44	75.0
subroutine	29	29	100.0
pod			n/a
total	460	501	91.8

use strict;

package DateTime::Set::ICal;

use vars qw(@ISA);
# use Carp;

# a "dt::set" with a symbolic string representation
@ISA = qw( DateTime::Set );

sub set_ical { # include list, exclude list
    my $self = shift;
    # carp "set_ical $_[0] => @{$_[1]}" if @_;
    $self->{as_ical} = [ @_ ];
    $self;
}

sub get_ical {
    my $self = shift;
    return unless $self->{as_ical};
    return @{ $self->{as_ical} };
}

sub clone {
    my $self = shift;
    my $new = $self->SUPER::clone( @_ );
    $new->set_ical( $self->get_ical );
    $new;
}

sub union {
    my $self = shift;
    my $new = $self->SUPER::union( @_ );

    # RFC2445 - op1, op2 must have no 'exclude'
    my (%op1, %op2);
    %op1 = ( $self->get_ical ) if ( UNIVERSAL::can( $self, 'get_ical' ) );
    %op2 = ( $_[0]->get_ical ) if ( UNIVERSAL::can( $_[0], 'get_ical' ) );
    return $new if ( ( exists $op1{exclude} ) ||
                     ( exists $op2{exclude} ) );

    bless $new, 'DateTime::Set::ICal';
    # warn " -- 1 isa @{[%op1]} -- 2 isa @{[%op2]} -- ";
    my @ical;
    @ical = exists $op1{include} ?
            @{$op1{include}} :
            $self;

    # push @ical, @{$op2{include}}, @_;
    if ( exists $op2{include} )
    {
        push @ical, @{$op2{include}};
    }
    else
    {
        push @ical, @_;  # whatever...
    }
    # warn "union: @ical";
    $new->set_ical( include => [ @ical ] );
    $new;
}

sub complement {
    my $self = shift;
    my $new = $self->SUPER::complement( @_ );
    return $new unless @_;

    # RFC2445 - op2 must have no 'exclude'
    my (%op1, %op2);
    %op1 = ( $self->get_ical ) if ( UNIVERSAL::can( $self, 'get_ical' ) );
    %op2 = ( $_[0]->get_ical ) if ( UNIVERSAL::can( $_[0], 'get_ical' ) );
    return $new if ( exists $op2{exclude} );

    bless $new, 'DateTime::Set::ICal';
    # warn " -- 1 isa @{[%op1]} -- 2 isa @{[%op2]} -- ";
    my ( @include, @exclude );
    @include = exists $op1{include} ?
               @{$op1{include}} :
               $self;

    @exclude = exists $op1{exclude} ?
               @{$op1{exclude}} :
               ();

    if ( exists $op2{include} )
    {
        push @exclude, @{$op2{include}};
    }
    else
    {
        push @exclude, @_;  # whatever...
    }

    # warn "complement: include @include exclude @exclude";
    $new->set_ical( include => [ @include ], exclude => [ @exclude ] );
    $new;
}

package DateTime::Event::Recurrence;

use strict;
use DateTime;
use DateTime::Set;
use DateTime::Span;
use Params::Validate qw(:all);
use vars qw( $VERSION );
$VERSION = '0.16';

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

# -------- BASE OPERATIONS

use vars qw(
    %as_number

    %truncate
    %next_unit
    %previous_unit

    %truncate_interval
    %next_unit_interval
    %previous_unit_interval

    %weekdays
    %weekdays_1
    %weekdays_any

    %memoized_duration

    %ical_name
    %ical_days
    %limits
    @units
);

BEGIN {
    %weekdays =   qw(  mo 1   tu 2   we 3   th 4   fr 5   sa 6   su 7 );
    %weekdays_1 = qw( 1mo 1  1tu 2  1we 3  1th 4  1fr 5  1sa 6  1su 7 );
    %weekdays_any = ( %weekdays, %weekdays_1 );

    %ical_name =  qw(
        months  BYMONTH
        weeks   BYWEEKNO
        days    BYMONTHDAY
        hours   BYHOUR
        minutes BYMINUTE
        seconds BYSECOND
    );

    %ical_days =  qw(
         1 MO  2 TU  3 WE  4 TH  5 FR  6 SA  7 SU
        -7 MO -6 TU -5 WE -4 TH -3 FR -2 SA -1 SU
    );

    @units = qw( years months weeks days hours minutes seconds nanoseconds );

    %limits = qw(
        nanoseconds 1000000000
        seconds     61
        minutes     60
        hours       24
        months      12
        weeks       53
        days        366
    );

} # BEGIN


# memoization reduces 'duration' creation from >10000 to about 30 per run,
# in DT::E::ICal

sub _add {
    # datetime, unit, value
    my $dur = \$memoized_duration{$_[1]}{$_[2]};
    $$dur = new DateTime::Duration( $_[1] => $_[2] )
        unless defined $$dur;
    $_[0]->add_duration( $$dur );
}

# TODO: %as_number should use the "subtract" routines from DateTime

%as_number = (
    years => sub {
        $_[0]->year
    },
    months => sub {
        12 * $_[0]->year + $_[0]->month - 1
    },
    days => sub {
        ( $_[0]->local_rd_values() )[0]
    },
    weeks => sub {
        # $_[1] is the "week start day", such as "1mo"
        use integer;
        return ( $as_number{days}->( $_[0] ) - $weekdays_any{ $_[1] } ) / 7;
    },
    hours => sub {
        $as_number{days}->($_[0]) * 24 + $_[0]->hour
    },
    minutes => sub {
        $as_number{hours}->($_[0]) * 60 + $_[0]->minute
    },
    seconds => sub {
        $_[0]->local_rd_as_seconds
    },
    years_weekly => sub {
        # get the internal year number, in 'week' mode
        # $_[1] is the "week start day", such as "1mo"
        my $base = $_[0]->clone;
        $base = $truncate{years_weekly}->( $base, $_[1] )
            if $base->month > 11 || $base->month < 2;
        _add( $base, weeks => 1 );
        return $as_number{years}->( $base );
    },
    months_weekly => sub {
        # get the internal month number, in 'week' mode
        # $_[1] is the "week start day", such as "1mo"
        my $base = $_[0]->clone;
        $base = $truncate{months_weekly}->( $base, $_[1] )
            if $base->day > 20 || $base->day < 7;
        _add( $base, weeks => 1 );
        return $as_number{months}->( $base );
    },
);


%truncate = (
    # @_ = ( $datetime, $week_start_day )

    (
        map {
              my $name = $_;
              $name =~ s/s$//;
              $_ => sub {
                           my $tmp = $_[0]->clone;
                           $tmp->truncate( to => $name )
                        }
            } qw( years months days hours minutes seconds )
    ),

    weeks   => sub {
        my $base = $_[0]->clone->truncate( to => 'day' );
        _add( $base, days => - $_[0]->day_of_week
                             + $weekdays_any{ $_[1] } );
        while(1) {
            return $base if $base <= $_[0];
            _add( $base, weeks => -1 );
        }
    },

    months_weekly => sub {
        my $tmp;
        my $base = $_[0]->clone;
        _add( $base, days => 7 );
        $base->truncate( to => 'month' );
        my $val;
        my $diff;
        while(1) {
            $tmp = $base->clone;
            $val = $weekdays_1{ $_[1] };
            if ( $val )
            {
                $diff = $val - $base->day_of_week;
                $diff += 7 if $diff < 0;
            }
            else
            {
                $diff = ( $weekdays{ $_[1] } -
                          $base->day_of_week ) % 7;
                $diff -= 7 if $diff > 3;
            }
            _add( $tmp, days =>  $diff );
            return $tmp if $tmp <= $_[0];
            _add( $base, months => -1 );
        }
    },

    years_weekly => sub {
        my $tmp;
        my $base = $_[0]->clone;
        _add( $base, months => 1 );
        $base->truncate( to => 'year' );
        my $val;
        my $diff;
        # warn "wsd $_[1]\n";
        while(1) {
            $tmp = $base->clone;
            $val = $weekdays_1{ $_[1] };
            if ( $val )
            {
                $diff = $val - $base->day_of_week;
                $diff += 7 if $diff < 0;
            }
            else
            {
                $diff = ( $weekdays{ $_[1] } -
                          $base->day_of_week ) % 7;
                $diff -= 7 if $diff > 3;
            }
            _add( $tmp, days =>  $diff );
            return $tmp if $tmp <= $_[0];
            _add( $base, years => -1 );
        }
    },
);

%next_unit = (
    # @_ = ( $datetime, $week_start_day )

    (
        map {
              my $names = $_;
              $_ => sub {
                           _add( $_[0], $names => 1 )
                        }
            } qw( years months weeks days hours minutes seconds )
    ),

    months_weekly => sub {
        my $base = $_[0]->clone;
        my $return;
        while(1) {
            _add( $base, days => 21 );
            $return = $truncate{months_weekly}->( $base, $_[1] );
            return $_[0] = $return if $return > $_[0];
        }
    },

    years_weekly => sub {
        my $base = $_[0]->clone;
        my $return;
        while(1) {
            _add( $base, months => 11 );
            $return = $truncate{years_weekly}->( $base, $_[1] );
            return $_[0] = $return if $return > $_[0];
        }
    },
);

%previous_unit = (
    # @_ = ( $datetime, $week_start_day )

    months_weekly => sub {
        my $base = $_[0]->clone;
        my $return;
        while(1) {
            $return = $truncate{months_weekly}->( $base, $_[1] );
            return $_[0] = $return if $return < $_[0];
            _add( $base, days => -21 );
        }
    },

    years_weekly => sub {
        my $base = $_[0]->clone;
        my $return;
        while(1) {
            $return = $truncate{years_weekly}->( $base, $_[1] );
            return $_[0] = $return if $return < $_[0];
            _add( $base, months => -11 );
        }
    },
);

# -------- "INTERVAL" OPERATIONS

%truncate_interval = (
    # @_ = ( $datetime, $args )

    (
        map {
              my $names = $_;
              my $name = $_;
              $name =~ s/s$//;
              $_ => sub {
                           my $tmp = $_[0]->clone;
                           $tmp->truncate( to => $name );
                           _add( $tmp, $names =>
                                     $_[1]{offset} -
                                     ( $as_number{$names}->($_[0]) %
                                       $_[1]{interval}
                                     )
                               );
                        }
            } qw( years months days hours minutes seconds )
    ),

    weeks   => sub {
        my $tmp = $truncate{weeks}->( $_[0], $_[1]{week_start_day} );
        while ( $_[1]{offset} !=
                ( $as_number{weeks}->(
                    $tmp, $_[1]{week_start_day} ) %
                  $_[1]{interval}
                )
              )
        {
            _add( $tmp, weeks => -1 );
        }
        return $tmp;
    },

    months_weekly => sub {
        my $tmp = $truncate{months_weekly}->( $_[0], $_[1]{week_start_day} );
        while ( $_[1]{offset} !=
                ( $as_number{months_weekly}->(
                    $tmp, $_[1]{week_start_day} ) %
                  $_[1]{interval}
                )
              )
        {
            $previous_unit{months_weekly}->( $tmp, $_[1]{week_start_day} );
        }
        return $tmp;
    },

    years_weekly => sub {
        my $tmp = $truncate{years_weekly}->( $_[0], $_[1]{week_start_day} );
        while ( $_[1]{offset} !=
                ( $as_number{years_weekly}->( $tmp, $_[1]{week_start_day} ) %
                    $_[1]{interval}
                )
              )
        {
            $previous_unit{years_weekly}->( $tmp, $_[1]{week_start_day} );
        }
        return $tmp;
    },
);

%next_unit_interval = (
    (
        map {
              my $names = $_;
              $_ => sub {
                           _add( $_[0], $names => $_[1]{interval} )
                        }
            } qw( years months weeks days hours minutes seconds )
    ),

    months_weekly => sub {
        for ( 1 .. $_[1]{interval} )
        {
            $next_unit{months_weekly}->( $_[0], $_[1]{week_start_day} );
        }
    },

    years_weekly => sub {
        for ( 1 .. $_[1]{interval} )
        {
            $next_unit{years_weekly}->( $_[0], $_[1]{week_start_day} );
        }
    },
);

%previous_unit_interval = (
    (
        map {
              my $names = $_;
              $_ => sub {
                           _add( $_[0], $names => - $_[1]{interval} )
                        }
            } qw( years months weeks days hours minutes seconds )
    ),

    months_weekly => sub {
        for ( 1 .. $_[1]{interval} )
        {
            $previous_unit{months_weekly}->( $_[0], $_[1]{week_start_day} );
        }
    },

    years_weekly => sub {
        for ( 1 .. $_[1]{interval} )
        {
            $previous_unit{years_weekly}->( $_[0], $_[1]{week_start_day} );
        }
    },
);

# -------- CONSTRUCTORS

BEGIN {
    # setup all constructors: daily, ...

    for ( @units[ 0 .. $#units-1 ] )
    {
        my $name = $_;
        my $namely = $_;
        $namely =~ s/ys$/ily/;
        $namely =~ s/s$/ly/;

        no strict 'refs';
        *{__PACKAGE__ . "::$namely"} =
            sub {
                    use strict 'refs';
                    my $class = shift;
                    return _create_recurrence( base => $name, @_ );
                };
    }
} # BEGIN


sub _create_recurrence {
    my %args = @_;

    # print "ARGS: ";
    # for(@_){ print (( ref($_) eq "ARRAY" ) ? "[ @$_ ] " : "$_ ") }
    # print " \n";

    # --- FREQUENCY

    my $base = delete $args{base};
    my $namely = $base;
    $namely =~ s/ys$/ily/;
    $namely =~ s/s$/ly/;
    my $ical_string = uc( "RRULE:FREQ=$namely" );
    my $base_unit = $base;
    $base_unit = 'years_weekly'
         if $base_unit eq 'years' &&
            exists $args{weeks} ;
    $base_unit = 'months_weekly'
         if $base_unit eq 'months' &&
            exists $args{weeks} ;

    # --- WEEK-START-DAY

    my $week_start_day = delete $args{week_start_day};
    $ical_string .= ";WKST=". uc($week_start_day)
        if $week_start_day;
    $week_start_day = ( $base eq 'years' ) ? 'mo' : '1mo'
        unless defined $week_start_day;
    die "$base: invalid week start day ($week_start_day)"
        unless $weekdays_any{ $week_start_day };

    # --- INTERVAL, START, and OFFSET

    my $interval = delete $args{interval} || 1;
    die "invalid 'interval' specification ($interval)"
        if $interval < 1;
    $ical_string .= ";INTERVAL=$interval"
        if $interval > 1;

    my $start = delete $args{start};
    undef $start
        if defined $start && $start->is_infinite;

    my $offset = 0;
    $offset = $as_number{$base_unit}->( $start, $week_start_day ) % $interval
        if $start && $interval > 1;

    # --- DURATION LIST

    # check for invalid "units" arguments, such as "daily( years=> )"
    my @valid_units;
    for ( 0 .. $#units )
    {
        if ( $base eq $units[$_] )
        {
            @valid_units = @units[ $_+1 .. $#units ];
            last;
        }
    }
    die "can't have both 'months' and 'weeks' arguments"
        if exists $args{weeks} &&
           exists $args{months};

    my $level = 1;
    my @duration =   ( [] );
    my @level_unit = ( $base_unit );
    for my $unit ( @valid_units )
    {
            next unless exists $args{$unit};

            if ( ref( $args{$unit} ) eq 'ARRAY' )
            {
                $args{$unit} = [ @{ $args{$unit} } ]
            }
            else
            {
                $args{$unit} = [ $args{$unit} ]
            }

            # TODO: sort _after_ normalization

            if ( $unit eq 'days' )
            {
                # map rfc2445 weekdays to numbers
                @{$args{$unit}} =
                    map {
                          $_ =~ /[a-z]/ ? $weekdays{$_} : $_
                        } @{$args{$unit}};
            }

            # sort positive values first
            @{$args{$unit}} =
                sort {
                       ( $a < 0 ) <=> ( $b < 0 ) || $a <=> $b
                     } @{$args{$unit}};


            # make the "ical" string
            if ( $unit eq 'nanoseconds' )
            {
                # there are no nanoseconds in ICal
            }
            elsif ( $base eq 'weeks' &&
                    $unit eq 'days' )
            {
                # weekdays have names
                $ical_string .= uc( ';' . 'BYDAY' . '=' .
                    join(",",
                        map {
                              exists( $ical_days{$_} ) ? $ical_days{$_} : $_
                            } @{$args{$unit}} )
                  )
            }
            else
            {
                $ical_string .= uc( ';' . $ical_name{$unit} . '=' .
                                join(",", @{$args{$unit}} ) )
            }

            if ( $unit eq 'months' ||
                 $unit eq 'weeks' ||
                 $unit eq 'days' )
            {
                # these units start in '1'
                for ( @{$args{$unit}} )
                {
                    die $unit . ' cannot be zero'
                        unless $_;
                    $_-- if $_ > 0;
                }
            }

            @{$args{$unit}} =
                    grep {
                           $_ < $limits{ $unit } &&
                           $_ >= - $limits{ $unit }
                         } @{$args{$unit}};

            if ( $unit eq 'days' &&
                 ( $base_unit eq 'months' ||
                   $level_unit[-1] eq 'months' ) )
            {   # month day
                    @{$args{$unit}} =
                        grep {
                               $_ < 31 && $_ >= -31
                             } @{$args{$unit}};
            }

            if ( $unit eq 'days' &&
                 ( $base_unit eq 'weeks' ||
                   $level_unit[-1] eq 'weeks' ) )
            {   # week day

                    @{$args{$unit}} =
                        grep {
                               $_ < 7 && $_ >= -7
                             } @{$args{$unit}};

                    for ( @{$args{$unit}} )
                    {
                        $_ = $_ - $weekdays_any{ $week_start_day } + 1;
                        $_ += 7 while $_ < 0;
                    }

                    @{$args{$unit}} = sort @{$args{$unit}};
            }

            return DateTime::Set::ICal->empty_set
                unless @{$args{$unit}};  # there are no args left

            push @duration, $args{$unit};
            push @level_unit, $unit;

            delete $args{$unit};

            $level++;
    }

    # TODO: use $span for selecting elements (using intersection)
    # note - this may change the documented behaviour - check the pod first
    # $span = delete $args{span};
    # $span = DateTime::Span->new( %args ) if %args;

    die "invalid argument '@{[ keys %args ]}'"
        if keys %args;

    # --- SPLIT NEGATIVE/POSITIVE DURATIONS

    my @args;
    push @args, \@duration;

    for ( my $i = 0; $i < @args; $i++ )
    {
        my $dur1 = $args[$i];
        for ( 1 .. $#{$dur1} )
        {
            my @negatives = grep { $_ <  0 } @{$dur1->[$_]};
            my @positives = grep { $_ >= 0 } @{$dur1->[$_]};
            if ( @positives && @negatives )
            {
                # split
                # TODO: check if it really needs splitting
                my $dur2 = [ @{$args[$i]} ];
                $dur2->[$_] = \@negatives;
                $dur1->[$_] = \@positives;
                push @args, $dur2;
            }
        }
    }

    # --- CREATE THE SET

    my $set;
    for ( @args )
    {
        my @duration = @$_;
        my $total_durations = 1;
        my @total_level;
        for ( my $i = $#duration; $i > 0; $i-- )
        {
            if ( $i == $#duration )
            {
                $total_level[$i] = 1;
            }
            else
            {
                $total_level[$i] = $total_level[$i + 1] *
                                   ( 1 + $#{ $duration[$i + 1] } );
            }
            $total_durations *= 1 + $#{ $duration[$i] };
        }

        my $args =  {
            truncate_interval =>      $truncate_interval{ $base_unit },
            previous_unit_interval => $previous_unit_interval{ $base_unit },
            next_unit_interval =>     $next_unit_interval{ $base_unit },

            duration =>        \@duration,
            total_durations => $total_durations,
            level_unit =>      \@level_unit,
            total_level =>     \@total_level,

            interval =>        $interval,
            offset =>          $offset,
            week_start_day =>  $week_start_day,
        };

        my $tmp = DateTime::Set::ICal->from_recurrence(
                          next => sub {
                              _get_next( $_[0], $args );
                          },
                          previous => sub {
                              _get_previous( $_[0], $args );
                          },
        );

        $set = defined $set ? $set->union( $tmp ) : $tmp;
    }
    $set->set_ical( include => [ $ical_string ] );
    # warn "Creating set: ". $ical_string ." \n";

    return $set;

} # _create_recurrence


sub _get_occurrence_by_index {
    my ( $base, $occurrence, $args ) = @_;
    # TODO: memoize "occurrences" within an "INTERVAL" ???
    RETRY_OVERFLOW: for ( 0 .. 5 )
    {
        return undef
            if  $occurrence < 0;
        my $next = $base->clone;
        my $previous = $base;
        my @values = ( -1 );
        for my $j ( 1 .. $#{$args->{duration}} )
        {
            # decode the occurrence-number into a parameter-index
            my $i = int( $occurrence / $args->{total_level}[$j] );
            $occurrence -= $i * $args->{total_level}[$j];
            push @values, $i;

            if ( $args->{duration}[$j][$i] < 0 )
            {
                # warn "negative unit\n";
                $next_unit{ $args->{level_unit}[$j - 1] }->(
                    $next, $args->{week_start_day} );
            }
            _add( $next, $args->{level_unit}[$j], $args->{duration}[$j][$i] );

            # overflow check
            if ( $as_number{ $args->{level_unit}[$j - 1] }->(
                    $next, $args->{week_start_day} ) !=
                 $as_number{ $args->{level_unit}[$j - 1] }->(
                    $previous, $args->{week_start_day} )
               )
            {
                # calculate the "previous" occurrence-number
                $occurrence = -1;
                for ( 1 .. $j )
                {
                    $occurrence += $values[$_] * $args->{total_level}[$_];
                }
                next RETRY_OVERFLOW;
            }
            $previous = $next->clone;
        }
        return $next;
    }
    return undef;
}


sub _get_previous {
    my ( $self, $args ) = @_;

    return $self if $self->is_infinite;

    my $base = $args->{truncate_interval}->( $self, $args );
    my ( $next, $i, $start, $end );
    my $init = 0;
    my $retry = 30;

    INTERVAL: while(1) {
            $args->{previous_unit_interval}->( $base, $args ) if $init;
            $init = 1;

            # binary search
            $start = 0;
            $end = $args->{total_durations} - 1;
            while ( $retry-- ) {
                if ( $end - $start < 3 )
                {
                    for ( $i = $end; $i >= $start; $i-- )
                    {
                        $next = _get_occurrence_by_index ( $base, $i, $args );
                        next INTERVAL unless defined $next;
                        return $next if $next < $self;
                    }
                    next INTERVAL;
                }

                $i = int( $start + ( $end - $start ) / 2 );
                $next = _get_occurrence_by_index ( $base, $i, $args );
                next INTERVAL unless defined $next;

                if ( $next < $self )
                {
                    $start = $i;
                }
                else
                {
                    $end = $i - 1;
                }
            }
            return undef;
    }
}


sub _get_next {
    my ( $self, $args ) = @_;

    return $self if $self->is_infinite;

    my $base = $args->{truncate_interval}->( $self, $args );
    my ( $next, $i, $start, $end );
    my $init = 0;
    my $retry = 30;

    INTERVAL: while(1) {
            $args->{next_unit_interval}->( $base, $args ) if $init;
            $init = 1;

            # binary search
            $start = 0;
            $end = $args->{total_durations} - 1;
            while ( $retry-- ) {
                if ( $end - $start < 3 )
                {
                    for $i ( $start .. $end )
                    {
                        $next = _get_occurrence_by_index ( $base, $i, $args );
                        next INTERVAL unless defined $next;
                        return $next if $next > $self;
                    }
                    next INTERVAL;
                }

                $i = int( $start + ( $end - $start ) / 2 );
                $next = _get_occurrence_by_index ( $base, $i, $args );
                next INTERVAL unless defined $next;

                if ( $next > $self )
                {
                    $end = $i;
                }
                else
                {
                    $start = $i + 1;
                }
            }
            return undef;
    }
}

1;

__END__