File Coverage

blib/lib/DateTime/Format/ICal.pm

Criterion	Covered	Total	%
statement	158	168	94.0
branch	88	110	80.0
condition	35	45	77.7
subroutine	16	17	94.1
pod	9	10	90.0
total	306	350	87.4

package DateTime::Format::ICal;

use strict;

use vars qw ($VERSION);

$VERSION = '0.09';

use DateTime;
use DateTime::Span;
use DateTime::Event::ICal;

use Params::Validate qw( validate_with SCALAR );

sub new
{
    my $class = shift;

    return bless {}, $class;
}

# key is string length
my %valid_formats =
    ( 15 =>
      { params => [ qw( year month day hour minute second ) ],
        regex  => qr/^(\d\d\d\d)(\d\d)(\d\d)T(\d\d)(\d\d)(\d\d)$/,
      },
      13 =>
      { params => [ qw( year month day hour minute ) ],
        regex  => qr/^(\d\d\d\d)(\d\d)(\d\d)T(\d\d)(\d\d)$/,
      },
      11 =>
      { params => [ qw( year month day hour ) ],
        regex  => qr/^(\d\d\d\d)(\d\d)(\d\d)T(\d\d)$/,
      },
      8 =>
      { params => [ qw( year month day ) ],
        regex  => qr/^(\d\d\d\d)(\d\d)(\d\d)$/,
      },
    );

sub parse_datetime
{
    my ( $self, $date ) = @_;

    # save for error messages
    my $original = $date;

    my %p;
    if ( $date =~ s/^TZID=([^:]+):// )
    {
        $p{time_zone} = $1;
    }
    # Z at end means UTC
    elsif ( $date =~ s/Z$// )
    {
        $p{time_zone} = 'UTC';
    }
    else
    {
        $p{time_zone} = 'floating';
    }

    my $format = $valid_formats{ length $date }
        or die "Invalid iCal datetime string ($original)\n";

    @p{ @{ $format->{params} } } = $date =~ /$format->{regex}/;

    return DateTime->new(%p);
}

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

    my @units = qw( weeks days hours minutes seconds );

    $dur =~ m{ ([\+\-])?         # Sign
               P                 # 'P' for period? This is our magic character)
               (?:
                   (?:(\d+)W)?   # Weeks
                   (?:(\d+)D)?   # Days
               )?
               (?: T             # Time prefix
                   (?:(\d+)H)?   # Hours
                   (?:(\d+)M)?   # Minutes
                   (?:(\d+)S)?   # Seconds
               )?
             }x;

    my $sign = $1;

    my %units;
    $units{weeks}   = $2 if defined $2;
    $units{days}    = $3 if defined $3;
    $units{hours}   = $4 if defined $4;
    $units{minutes} = $5 if defined $5;
    $units{seconds} = $6 if defined $6;

    die "Invalid ICal duration string ($dur)\n"
        unless %units;

    if ( defined $sign && $sign eq '-' )
    {
        # $_ *= -1 foreach values %units;  - does not work in 5.00503
        $units{$_} *= -1 foreach keys %units;
    }

    return DateTime::Duration->new(%units);
}

sub parse_period
{
    my ( $self, $period ) = @_;

    my ( $start, $end ) = $period =~ /^((?:TZID=[^:]+:)?.*?)\/(.*)/;

    die "Invalid ICal period string ($period)\n"
        unless $start && $end;

    $start = $self->parse_datetime( $start );

    if ( $end =~ /[\+\-]P/i ) {
        $end = $start + $self->parse_duration( $end );
    }
    else
    {
        $end = $self->parse_datetime( $end );
    }

    die "Invalid ICal period: end before start ($period)\n"
        if $start > $end;

    return DateTime::Span->new( start => $start, end => $end );
}

sub parse_recurrence
{
    my $self = shift;
    my %p = validate_with( params => \@_,
                           spec   => { recurrence => { type => SCALAR } },
                           allow_extra => 1,
                         );

    my $recurrence = delete $p{recurrence};

    # recurrence may start with RRULE:
    $recurrence =~ s/^(?:RRULE|EXRULE)://i;

    # parser: adapted from code written for Date::Set by jesse
    # RRULEs look like 'FREQ=foo;INTERVAL=bar;' etc.
    foreach ( split /;/, $recurrence )
    {
        my ( $name, $value ) = split /=/;

        $name  = lc $name;

        # BY parameters should be arrays. everything else should be strings
        if ( $name eq 'until' )
        {
            $p{$name} = __PACKAGE__->parse_datetime( $value );
        }
        elsif ( $name =~ /^by/i )
        {
            $p{$name} = [ split /,/, lc( $value ) ];
        }
        else
        {
            $p{$name} = lc( $value );
        }
    }

    return DateTime::Event::ICal->recur(%p);
}

sub format_datetime
{
    my ( $self, $dt ) = @_;

    my $tz = $dt->time_zone;

    unless ( $tz->is_floating ||
             $tz->is_utc ||
             $tz->is_olson )
    {
        $dt = $dt->clone->set_time_zone('UTC');
        $tz = $dt->time_zone;
    }

    my $base =
        sprintf( '%04d%02d%02dT%02d%02d%02d',
                 $dt->year, $dt->month, $dt->day,
                 $dt->hour, $dt->minute, $dt->second );

    return $base if $tz->is_floating;

    return $base . 'Z' if $tz->is_utc;

    return 'TZID=' . $tz->name . ':' . $base;
}

sub format_duration
{
    my ( $self, $duration ) = @_;

    die "Cannot represent years or months in an iCal duration\n"
        if $duration->delta_months;

    # simple string for 0-length durations
    return '+PT0S'
        unless $duration->delta_days ||
               $duration->delta_minutes ||
               $duration->delta_seconds;

    my $ical = $duration->is_positive ? '+' : '-';
    $ical .= 'P';

    if ( $duration->delta_days )
    {
        $ical .= $duration->weeks . 'W' if $duration->weeks;
        $ical .= $duration->days  . 'D' if $duration->days;
    }

    if ( $duration->delta_minutes || $duration->delta_seconds )
    {
        $ical .= 'T';

        $ical .= $duration->hours   . 'H' if $duration->hours;
        $ical .= $duration->minutes . 'M' if $duration->minutes;
        $ical .= $duration->seconds . 'S' if $duration->seconds;
    }

    return $ical;
}


sub format_period
{
    my ( $self, $span ) = @_;

    return $self->format_datetime( $span->start ) . '/' .
           $self->format_datetime( $span->end ) ;
}

sub format_period_with_duration
{
    my ( $self, $span ) = @_;

    return $self->format_datetime( $span->start ) . '/' .
           $self->format_duration( $span->duration ) ;
}


sub _split_datetime_tz
{
    my ( $self, $dt ) = @_;

    my $tz = $dt->time_zone;

    unless ( $tz->is_floating ||
             $tz->is_utc ||
             $tz->is_olson )
    {
        $dt = $dt->clone->set_time_zone('UTC');
        $tz = $dt->time_zone;
    }

    my $base =
        ( $dt->hour || $dt->min || $dt->sec ?
          sprintf( '%04d%02d%02dT%02d%02d%02d',
                   $dt->year, $dt->month, $dt->day,
                   $dt->hour, $dt->minute, $dt->second ) :
          sprintf( '%04d%02d%02d', $dt->year, $dt->month, $dt->day )
        );

    return ($base, '')    if $tz->is_floating;
    return ($base, 'UTC') if $tz->is_utc;
    return ($base, $tz->name);
}

sub format_recurrence
{
    my ( $self, $set, @more ) = @_;
    my @result;

    # normalize param to either DT::Set or DT::SpanSet
    # DT list =>       convert to DT::Set
    # DT::Span list => convert to DT::SpanSet

    if ( $set->isa('DateTime') )
    {
        $set = DateTime::Set->from_datetimes( dates => [ $set, @more ] );
    }
    elsif ( $set->isa('DateTime::Span') )
    {
        $set = DateTime::SpanSet->from_spans( spans => [ $set, @more ] );
    }

    # is it a recurrence?
    if ( $set->{set}->is_too_complex )
    {
        # DT::Set recurrence => DTSTART;timezone:date CRLF
        #                       RRULE:params CRLF
        #   note: add more lines if necessary:
        #             union =        more RRULE/RDATE lines
        #             complement =   more EXRULE/EXDATE lines
        #             intersection = ?
        #   note: timezone is specified by DTSTART only.

        # TODO: add support to DT::Event::Recurrence objects

        if ( $set->can( 'get_ical' ) && defined $set->get_ical )
        {
            my %ical = $set->get_ical;
            for ( @{ $ical{include} } )
            {
                next unless $_;
                if ( ref( $_ ) )
                {
                    push @result, $self->format_recurrence( $_ );
                }
                else
                {
                    push @result, $_;
                }
            }
            if ( $ical{exclude} )
            {
                my @exclude;
                for ( @{ $ical{exclude} } )
                {
                    next unless $_;
                    if ( ref( $_ ) )
                    {
			push @exclude, $self->format_recurrence( $_ );
                    }
                    else
                    {
			push @exclude, $_;
                    }
                }
                s/^RDATE/EXDATE/ for @exclude;
                s/^RRULE/EXRULE/ for @exclude;
                push @result, @exclude;
            }
        }
        else
        {
            die "format_recurrence() - Format not implemented for this unbounded set";
        }

        # end: format recurrence
    }
    else
    {
        # DT::Set  =>        RDATE:datetime,datetime,datetime CRLF
        # DT::SpanSet =>     RDATE;VALUE=PERIOD:period,period CRLF
        #
        # not supported =>   RDATE;VALUE=DATE:date,date,date CRLF
        #
        # DT::Set w/tz =>     RDATE;timezone:date,date CRLF
        # DT::SpanSet w/tz => RDATE;VALUE=PERIOD;timezone:period,period CRLF

        my $iterator = $set->iterator;
        my $last_type = 'DateTime';
        my $last_tz =   'invalid';
        my $item;

        while( $item = $iterator->next )
        {
            if( $item->isa('DateTime') )
            {
                my ($base,$tz) = $self->_split_datetime_tz( $item );
                if( $last_tz eq $tz &&
                    $last_type eq 'DateTime' )
                {
                    $result[-1] .= ',' . $base;
                    $result[-1] .= 'Z' if $tz eq 'UTC';
                }
                else
                {
                    push @result, 'RDATE';
                    $result[-1] .= ';TZID='.$tz if $tz ne '' && $tz ne 'UTC';
                    $result[-1] .= ':' . $base;
                    $result[-1] .= 'Z' if $tz eq 'UTC';
                    $last_tz =   $tz;
                    $last_type = 'DateTime';
                }
            }
            elsif( $item->isa('DateTime::Span') )
            {
                my $item_start = $item->start;
                my $item_end =   $item->end;
                if ( $item_start == $item_end )
                {
                    $item = $item_start;
                    # item looks like a datetime
                    redo;
                }
                my ($start,$tz) = $self->_split_datetime_tz( $item_start );
                $item_end->set_time_zone( $tz );
                my ($end,undef) = $self->_split_datetime_tz( $item_end );
                if( $last_tz eq $tz &&
                    $last_type eq 'DateTime::Span' )
                {
                    $result[-1] .= ',' . $start;
                    $result[-1] .= 'Z' if $tz eq 'UTC';
                    $result[-1] .= '/' . $end;
                    $result[-1] .= 'Z' if $tz eq 'UTC';
                }
                else
                {
                    push @result, 'RDATE;VALUE=PERIOD';
                    $result[-1] .= ';TZID='.$tz if $tz ne '' && $tz ne 'UTC';
                    $result[-1] .= ':' . $start;
                    $result[-1] .= 'Z' if $tz eq 'UTC';
                    $result[-1] .= '/' . $end;
                    $result[-1] .= 'Z' if $tz eq 'UTC';
                    $last_tz =   $tz;
                    $last_type = 'DateTime::Span';
                }
            }
            else
            {
                die 'unexpected data type "'.ref($item).'" in set';
            }
        }

        # end: format list of dates
    }
    return join( "\n", @result ) if ! wantarray;
    return @result;
}

1;

__END__