File Coverage

blib/lib/Data/ICal/DateTime.pm

Criterion	Covered	Total	%
statement	243	290	83.7
branch	66	86	76.7
condition	33	50	66.0
subroutine	31	34	91.1
pod	20	20	100.0
total	393	480	81.8

package Data::ICal::DateTime;

use strict;
use Clone;
use Data::ICal;
use DateTime::Set;
use DateTime::Format::ICal;

our $VERSION = '0.7';

# mmm, mixin goodness
sub import {
    my $class = shift;
    no strict 'refs';
    no warnings 'redefine';
    *Data::ICal::events   = \&events;
    *Data::ICal::collapse = \&collapse;
    foreach my $sub (qw(start end duration period summary description original
                        all_day floating recurrence recurrence_id rdate exrule exdate uid
                        _rule_set _date_set explode is_in _normalise split_up _escape _unescape))
    {
        *{"Data::ICal::Entry::Event::$sub"} = \&$sub;
    }
    push @Data::ICal::Entry::Event::ISA, 'Clone';
}



=head1 NAME

Data::ICal::DateTime - convenience methods for using Data::ICal with DateTime

=head1 SYNPOSIS

    # performs mixin voodoo
    use Data::ICal::DateTime;
    my $cal = Data::ICal->new( filename => 'example.ics');


    my $date1 = DateTime->new( year => 2005, month => 7, day => 01 );
    my $date2 = DateTime->new( year => 2005, month => 7, day => 07 );
    my $span  = DateTime::Span->from_datetimes( start => $date1, end => $date2 );

    my @events = $cal->events();           # all VEVENTS
    my @week   = $cal->events($span);      # just in that week
    my @week   = $cal->events($span,'day');# explode long events into days

    my $event = Data::ICal::Entry::Event->new();

    $event->start($start);                 # $start is a DateTime object
    $event->end($end);                     # so is $end

    $event->all_day                        # is this an all day event

    $event->duration($duration);           # $duration is DateTime::Duration
    $event->recurrence($recurrence);       # $reccurence is a DateTime list,
                                           # a DateTime::Span list,
                                           # a DateTime::Set,
                                           # or a DateTime::SpanSet

    $event->start;                         # returns a DateTime object
    $event->end;                           # ditto
    $event->duration;                      # returns a DateTime::Duration
    $event->recurrence;                    # returns a DateTime::Set
    $event->period;                        # returns a DateTime::Span object
    $event->rdate;                         # returns a DateTime::Set
    $event->exrule;                        # returns a DateTime::Set
    $event->exdate;                        # returns a DateTime::Set
    $event->explode($span);                # returns an array of sub events
                                           # (if this is recurring);
    $event->explode($span,'week');         # if any events are longer than a
                                           # week then split them up
    $event->is_in($span);                  # whether this event falls within a
                                           # Set, Span, or SetSpan


    $cal->add($event);

methods


=head1 DESCRIPTION

=head1 METHODS

=cut

=head2 events [span] [period]

Provides a L object with a method to return all events.

If a L, L or L object
is passed then only the events that occur within that set will be
returned including expansion of all recurring events. All events will be
normalised to have a dtstart and dtend rather than any other method of
determining their start and stop time.

Additionally you can pass a period string which can be one of the
following

    year month week day hour minute second

This will explode an event into as many sub events as needed e.g a
period of 'day' will explode a 2-day event into 2 one day events with
the second starting just after the first

=cut

sub events {
    my $self   = shift;
    my $set    = shift;
    my $period = shift;


    my @events = grep  { $_->ical_entry_type eq 'VEVENT' } @{$self->entries};

    # NOTE: this won't normalise events
    return @events if (!$set);
    @events = map { $_->explode($set) } @events;
    @events = $self->collapse(@events);

    return @events unless defined $period;
    return map { $_->split_up($period) } @events;

}

=head2 collapse

Provides a L object with a method to collapse Cs.

Given a list of events, some of which might have Cs,
return a list of events with all recurrences within C and all
Cs handled correctly.

Used internally by C.

=cut

sub collapse {
    my ($self, @events) = @_;

    my %rid;

    my @recurs;
    for (@events) {
        my $uid = $_->uid;
        # TODO: this feels very hacky
        $uid = rand().{}.time unless defined $uid;
        $_->uid($uid);
        if ($_->recurrence_id) {
            push @recurs, $_;
        } else {
            push @{$rid{$uid}}, $_;
        }
    }

    foreach my $e (@recurs) {
        my $uid = $e->uid;
        for (@{$rid{$uid}}) {
            next unless $_->start == $e->recurrence_id;
            # TODO: does this need to merge fields?
            $_ = $e;
        }
    }
    @events = ();
    push @events, @{$rid{$_}} for keys %rid;
    return @events;


}


=head2 start [new]

Returns a L object representing the start time of this event.

May return undef.

If passed a L object will set that to be the new start time.

=cut

sub start {
    my $self = shift;
    my $new  = shift;

    if ($new) {
         delete $self->{properties}->{dtstart};
         $self->add_property(dtstart => DateTime::Format::ICal->format_datetime($new));
    }


    my $dtstart = $self->property('dtstart') || return undef;
    my $ret     = DateTime::Format::ICal->parse_datetime($dtstart->[0]->value);

    # $ret->set_time_zone($dtstart->[0]->parameters->{TZID}) if $dtstart->[0]->parameters->{TZID};

    return $ret;

}

=head2 end

Returns a L object representing the end time of this event.

May return undef.

If passed a L object will set that to be the new end time.

=cut


sub end {
    my $self = shift;
    my $new  = shift;

    # iCal represents all-day events by using ;VALUE=DATE
    # and setting DTEND=end_date + 1
    my $all_day = $self->all_day;

    if ($new) {
         delete $self->{properties}->{dtend};
         my $update = $new->clone;
         if ($all_day) {
             $update->add( days => 1);
             $update->set( hour => 0, minute => 0, second => 0 );
         }
         $self->add_property( dtend => DateTime::Format::ICal->format_datetime($update) );
         $self->property('dtend')->[0]->parameters->{VALUE} = 'DATE' if $all_day;

    }


    my $dtend  = $self->property('dtend') || return undef;
    my $ret    = DateTime::Format::ICal->parse_datetime($dtend->[0]->value);

    # $ret->set_time_zone($dtend->[0]->parameters->{TZID}) if ($dtend->[0]->parameters->{TZID});
    $ret->truncate(to => 'day' )->subtract( nanoseconds => 1 ) if $all_day;

    return $ret;
}

=head2 all_day

Returns 1 if event is all day or 0 if not.

If no end has been set and 1 is passed then will set end to be a
nanosecond before midnight the next day.

=cut

sub all_day {
    my $self = shift;
    my $new  = shift;

    # TODO - should be able to make all day with just the start
    my $dtend  = $self->property('dtend');

    if (!$dtend) {
        return 0 unless $new;
        $dtend = $self->start->clone->add( days => 1 )->truncate(to => 'day' )->subtract( nanoseconds => 1 );
        $self->end($dtend);
        $dtend  = $self->property('dtend');
    }

    my $cur = (defined $dtend && defined $dtend->[0]->parameters->{VALUE} && $dtend->[0]->parameters->{VALUE} eq 'DATE') || 0;

    if (defined $new && $new != $cur) {
        my $end = $self->end;
        if ($new == 0) {
            delete $self->property('dtend')->[0]->parameters->{VALUE};
        } else {
            $self->property('dtend')->[0]->parameters->{VALUE} = 'DATE';
        }
        $self->end($end);
        $cur = $new;
    }

    return $cur;
}

=head2 floating

An event is considered floating if it has a start but no end. It is intended
to represent an event that is associated with a given calendar date and time
of day, such as an anniversary and should not be considered as taking up any
amount of time.

Returns 1 if the evnt is floating and 0 if it isn't.

If passed a 1 then will set the event to be floating by deleting the end time.

If passed a 0 and no end is currently set then it will set end to be a
nanosecond before midnight the next day.

=cut

sub floating {
    my $self = shift;
    my $new  = shift;

    my $end  = $self->end;
    my $cur  = (defined $end)? 0 : 1;
    if (defined $new && $new != $cur) {
        # it is floating - delete the end
        if ($new) {
            delete $self->{properties}->{dtend};
        # it's not floating - simulate end as 1 nanosecond before midnight after the start
        } else {
            my $dtend = $self->start->clone->add( days => 1 )->truncate(to => 'day' )->subtract( nanoseconds => 1 );
            $self->end($dtend);
        }
        $cur = $new;
    }

    return $cur;

}

=head2 duration

Returns a L object representing the duration of this
event.

May return undef.

If passed a L object will set that to be the new
duration.

=cut

sub duration {
    my $self = shift;
    my $new  = shift;

    if ($new) {
         delete $self->{properties}->{duration};
         $self->add_property( duration => DateTime::Format::ICal->format_duration($new) );
    }

    my $duration = $self->property('duration') || return undef;
    return DateTime::Format::ICal->parse_duration($duration->[0]->value);
}


=head2 period

Returns a L object representing the period of this
event.

May return undef.

If passed a L object will set that to be the new
period.

=cut

sub period {
    my $self = shift;
    my $new  = shift;

    if ($new) {
        delete $self->{properties}->{period};
        $self->add_property( period => DateTime::Format::ICal->format_period($new) );
    }

    my $period  = $self->property('period') || return undef;
    my $ret     = DateTime::Format::ICal->parse_period($period->[0]->value);

    # $ret->set_time_zone($period->[0]->parameters->{TZID}) if ($period->[0]->parameters->{TZID});
    return $ret;
}


=head2 recurrence

Returns a L object representing the union of all the
Cs in this object.

May return undef.

If passed one or more L lists, L lists, Ls,
or Ls then set the recurrence rules to be those.

=cut

sub recurrence {
    my $self = shift;


    return $self->_rule_set('rrule', @_);
}

=head2 rdate

Returns a L object representing the set of all Cs in the object.

May return undef.

=cut

sub rdate {
    my $self = shift;

    return $self->_date_set('rdate', @_);
}


=head2 exrule

Returns a L object representing the union of all the
Cs in this object.

May return undef.

If passed one or more L lists, L lists, Ls,
or Ls then set the recurrence exclusion rules to be those.

=cut


sub exrule {
    my $self = shift;

    return $self->_rule_set('exrule', @_);

}

=head2 exdate

Returns a L object representing the set of all Cs in the object.

May return undef.

=cut

sub exdate {
    my $self = shift;

    return $self->_date_set('exdate', @_);
}



sub _date_set {
    my $self = shift;
    my $name = shift;


    $self->property($name) || return undef;
    my @dates;
    for (@{ $self->property($name) }) {
        foreach my $bit (split /,/, $_->value) {
            my $date     = DateTime::Format::ICal->parse_datetime($bit);
            # $date->set_time_zone($_->parameters->{TZID}) if $_->parameters->{TZID};
            push @dates, $date;
        }
    }
    return DateTime::Set->from_datetimes( dates => \@dates );

}


sub _rule_set {
    my $self  = shift;
    my $name  = shift;

    if (@_) {
        delete $self->{properties}->{$name};
        foreach my $rule (DateTime::Format::ICal->format_recurrence(@_)) {
            #$rule =~ s!^$name:!!i;
            $rule =~ s!^[^:]+:!!;
            $self->add_properties( $name => $rule  );
        }
    }


    my @recurrence;
    my $start = $self->start || return undef;
    my $tz    = $start->time_zone;

    $start = $start->clone;
    $start->set_time_zone("floating");

    my $set = DateTime::Set->empty_set;
    $self->property($name) || return undef;
    for (@{ $self->property($name) }) {
        my $recur   = DateTime::Format::ICal->parse_recurrence(recurrence => $_->value, dtstart => $start);
        # $recur->set_time_zone($_->parameters->{TZID}) if $_->parameters->{TZID};
        $set = $set->union($recur);
    }
    # $set->set_time_zone($tz);
    return $set;


}

=head2 recurrence_id

Returns a L object representing the recurrence-id of this event.

May return undef.

If passed a L object will set that to be the new recurrence-id.

=cut

sub recurrence_id {
    my $self = shift;
    my $new  = shift;

    if ($new) {
         delete $self->{properties}->{'recurrence-id'};
         $self->add_property('recurrence-id' => DateTime::Format::ICal->format_datetime($new));
    }


    my $rid  = $self->property('recurrence-id') || return undef;
    my $ret  = DateTime::Format::ICal->parse_datetime($rid->[0]->value);

    # $ret->set_time_zone($rid->[0]->parameters->{TZID}) if $rid->[0]->parameters->{TZID};

    return $ret;

}

=head2 uid

Returns the uid of this event.

If passed a new value then sets that to be the new uid value.

=cut

sub uid {
    my $self = shift;
    my $uid  = shift;

    if ($uid) {
        delete $self->{properties}->{uid};
        $self->add_property( uid => $uid );
    }

    $uid = $self->property('uid') || return undef;
    return $uid->[0]->value;

}

=head2 summary

Returns a string representing the summary of this event.

May return undef.

If passed a new value then sets that to be the new summary (and will escape all relevant characters).

=cut

sub summary {
    my $self = shift;
    my $summ = shift;

    if ($summ) {
        delete $self->{properties}->{summary};
        $self->add_property( summary => $summ );
    }

    $summ = $self->property('summary') || return undef;
    return $summ->[0]->value;
}

=head2 description

Returns a string representing the summary of this event.

May return undef.

If passed a new value then sets that to be the new description (and will escape all relevant characters).

=cut


sub description {
    my $self = shift;
    my $desc = shift;

    if ($desc) {
        delete $self->{properties}->{description};
        $self->add_property( description => $desc );
    }

    $desc = $self->property('description') || return undef;
    return $desc->[0]->value;

}


sub _escape {
    my $string = shift;
    $string =~ s!(\\|,|;)!\\$1!mg;
    $string =~ s!\x0a!\\n!mg;
    return $string;
}

sub _unescape {
    my $string = shift;
    $string =~ s!\\n!\x0a!gm;
    $string =~ s!(\\\\|\\,|\\;)!substr($1,-1)!gem;
    return $string;
}


=head2 explode  [period]

Takes L, L or L and
returns an array of events.

If this is not a recurring event, and it falls with the span, then it
will return one event with the dtstart and dtend properties set and no
other time information.

If this is a recurring event then it will return all times that this
recurs within the span. All returned events will have the dtstart and
dtend properties set and no other time information.

If C is optionally passed then events longer than C will
be exploded into multiple events.

C can be any of the following

    year month week day hour minute second

=cut

# this is quite heavily based on 'wgo' in the bin/ directory of Text::vFile::asData
sub explode {
    my $self   = shift;
    my $span   = shift;
    my $period = shift;
    my %e      = $self->_normalise;




    my @events;



    if (! $e{recur} && $e{span}->intersects($span) ) {
        my $event = $self->clone();
        delete $event->{properties}->{$_} for qw(rrule exrule rdate exdate duration period);
        $event->start($e{start});
        $event->end($e{end});
        push @events, $event;
    }


    if($e{recur} && $e{recur}->intersects($span)) {
        my $int_set = $e{recur}->intersection($span);


        # Change the event's recurrence details so that only the events
        # inside the time span we're interested in are listed.
        $e{recur} = $int_set;
        my $it    = $e{recur}->iterator;
        while(my $dt = $it->next()) {
            next if $e{exrule} && $e{exrule}->contains($dt);
            next if $e{exdate} && $e{exdate}->contains($dt);
            my $event = $self->clone();
            delete $event->{properties}->{$_} for qw(rrule exrule rdate exdate duration period);

            $event->start($dt);
            if (defined $e{duration}) {
                my $end = $dt + $e{duration};
                $event->end($end);
            }
            $event->all_day($self->all_day);
            $event->original($self);
            push @events, $event;

        }
    }
    return @events if (!defined $period);
    my @new;
    push @new, $_->split_up($period) for @events;
    return @new;
}

=head2 original

Store or fetch a reference to the original event this was derived from.

=cut

sub original {
    my $self = shift;

    $self->{_original} = $_[0] if @_;

    return $self->{_original};
}

=head2 split_up

Split an n-period event into n 1-period events.

=cut

sub split_up {
    my $event  = shift;
    my $period = shift;

    return ($event) if $event->floating;

    my @new;
    my $span = DateTime::Span->from_datetimes( start => $event->start, end => $event->end );
    my $dur  = DateTime::Duration->new("${period}s" => 1)->subtract( "nanoseconds" => 1 );
    my $r    = DateTime::Set->from_recurrence(
                                       recurrence => sub {
                                         $_[0]->truncate(to => $period )->add("${period}s" => 1);
                                       },
                                       span => $span);
    $r       = $r->union(DateTime::Set->from_datetimes(dates => [$event->start]));

    my $i    = $r->iterator;
    while (my $dt = $i->next) {
        last if $dt >= $event->end; # && !$event->all_day;
        my $e = $event->clone;
        $e->start($dt);
        $e->all_day(0);
        $e->original($event);
        # $e->all_day($event->all_day) if $period ne 'second' && $period ne 'minute' && $period ne 'day';

        my $end = $dt->truncate( to => $period )->add( "${period}s" => 1 )->subtract( nanoseconds => 1 );
        $e->end($end);
        push @new, $e;
    }
    # If, say we have a one week and 1 day event and period is
    # 'week' then need to truncate to one 1 week event and one
    # day event.
    # $end = $e{end} if ( defined $period && $e{end} < $end);
    $new[-1]->end($event->end); # if !$event->all_day;
    return @new;
}

=head2 is_in

Takes L, L or L and
returns whether this event can fall within that time frame.

=cut

sub is_in {
    my $self = shift;
    my $span = shift;

    my %e = $self->_normalise;


    return ( ( !$e{recur} && $e{span}->intersects($span)    )    ||
             (  $e{recur} && $e{recur}->intersection($span) ) );

}

# return normalised information about this event
sub _normalise {
    my $self = shift;

    my %e = ();

    $e{period}   = $self->period;
    $e{start}    = $self->start;
    $e{end}      = $self->end;
    $e{duration} = $self->duration;
    $e{recur}    = $self->recurrence;
    $e{exrule}   = $self->exrule;
    $e{rdate}    = $self->rdate;
    $e{exdate}   = $self->exdate;
    $e{rid}      = $self->recurrence_id;
    $e{uid}      = $self->uid;


    if (defined $e{period}) {
        if (defined $e{start} || defined $e{end}) {
            die "Found a period *and* a start or end:\n".$self->as_string;
        }

        $e{start} = $e{period}->start;
        $e{end}   = $e{period}->end;

    }



    if (!defined $e{start}) {
        die "Couldn't find start\n".$self->as_string;
    }

    if (defined $e{end} && defined $e{duration}) {
        die "Found both end *and* duration:\n".$self->as_string;
    }


    # events can be floating
    #if (!defined $e{end} && !defined $e{duration}) {
    #    die "Couldn't find end *or* duration:\n".$self->as_string;
    #}

    if (defined $e{duration}) {
        $e{end} = $e{start} + $e{duration};
    }

    if ($e{rdate}) {
        $e{recur} = (defined $e{recur}) ? $e{recur}->union($e{rdate}) : $e{rdate};
    }

    my $end = $e{end} || $e{start}->clone->add(seconds => 1 );
    $e{span}     = DateTime::Span->from_datetimes( start => $e{start}, end => $end );

    $e{duration} = $e{span}->duration if $e{end};

    return %e;
}


=head1 AUTHOR

Simon Wistow

=head1 COPYING

Copyright, 2005 Simon Wistow

Distributed under the same terms as Perl itself.

=head1 BUGS

Potential timezone problems?

=head1 SEE ALSO

L, L, L, L, L

=cut

1;