/tags/v2-104/lib/site/DateTime/Format/ICal.pm
Perl | 625 lines | 483 code | 109 blank | 33 comment | 58 complexity | 2c5bca1a8d8b7c11a245f0241fe2c451 MD5 | raw file
Possible License(s): GPL-2.0, LGPL-2.0, GPL-3.0
- package DateTime::Format::ICal;
- use strict;
- use vars qw ($VERSION);
- $VERSION = '0.08';
- 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};
- # 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 =~ tr/A-Z/a-z/;
- $value =~ tr/A-Z/a-z/ unless $name eq 'until';
- # BY<FOO> parameters should be arrays. everything else should be strings
- if ( $name =~ /^by/i )
- {
- $p{$name} = [ split /,/, $value ];
- }
- else
- {
- $p{$name} = $value;
- }
- }
- # NOTE: 'until' is parsed out of 'recurrence'
- $p{until} =
- __PACKAGE__->parse_datetime( $p{until} )
- if defined $p{until} && ! ref $p{until};
- 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 =
- ( $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 . '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 @result;
- }
- 1;
- __END__
- =head1 NAME
- DateTime::Format::ICal - Parse and format iCal datetime and duration strings
- =head1 SYNOPSIS
- use DateTime::Format::ICal;
- my $dt = DateTime::Format::ICal->parse_datetime( '20030117T032900Z' );
- my $dur = DateTime::Format::ICal->parse_duration( '+P3WT4H55S' );
- # 20030117T032900Z
- DateTime::Format::ICal->format_datetime($dt);
- # +P3WT4H55S
- DateTime::Format::ICal->format_duration($dur);
- =head1 DESCRIPTION
- This module understands the ICal date/time and duration formats, as
- defined in RFC 2445. It can be used to parse these formats in order
- to create the appropriate objects.
- =head1 METHODS
- This class offers the following methods.
- =over 4
- =item * parse_datetime($string)
- Given an iCal datetime string, this method will return a new
- C<DateTime> object.
- If given an improperly formatted string, this method may die.
- =item * parse_duration($string)
- Given an iCal duration string, this method will return a new
- C<DateTime::Duration> object.
- If given an improperly formatted string, this method may die.
- =item * parse_period($string)
- Given an iCal period string, this method will return a new
- C<DateTime::Span> object.
- If given an improperly formatted string, this method may die.
- =item * parse_recurrence( recurrence => $string, ... )
- Given an iCal recurrence description, this method uses
- C<DateTime::Event::ICal> to create a C<DateTime::Set> object
- representing that recurrence. Any parameters given to this method
- beside "recurrence" and "until" will be passed directly to the C<<
- DateTime::Event::ICal->recur >> method. If "until" is given as an
- iCal format datetime, it will be parsed and turned into an object
- first.
- If given an improperly formatted string, this method may die.
- This method accepts optional parameters "dtstart" and "dtend".
- These parameters must be C<DateTime> objects.
- The iCal spec requires that "dtstart" always be included in the
- recurrence set, unless this is an "exrule" statement. Since we don't
- know what kind of statement is being parsed, we do not include
- C<dtstart> in the recurrence set.
- =item * format_datetime($datetime)
- Given a C<DateTime> object, this methods returns an iCal datetime
- string.
- The iCal spec requires that datetimes be formatted either as floating
- times (no time zone), UTC (with a 'Z' suffix) or with a time zone id
- at the beginning ('TZID=America/Chicago;...'). If this method is
- asked to format a C<DateTime> object that has an offset-only time
- zone, then the object will be converted to the UTC time zone
- internally before formatting.
- For example, this code:
- my $dt = DateTime->new( year => 1900, hour => 15, time_zone => '-0100' );
- print $ical->format_datetime($dt);
- will print the string "19000101T160000Z".
- =item * format_duration($duration)
- Given a C<DateTime::Duration> object, this methods returns an iCal
- duration string.
- The iCal standard does not allow for months or years in a duration, so
- if a duration for which C<delta_months()> is not zero is given, then
- this method will die.
- =item * format_period($span)
- Given a C<DateTime::Span> object, this methods returns an iCal
- period string, using the format C<DateTime/DateTime>.
- =item * format_period_with_duration($span)
- Given a C<DateTime::Span> object, this methods returns an iCal
- period string, using the format C<DateTime/Duration>.
- =item * format_recurrence($arg [,$arg...] )
- This method returns a list of strings containing ICal statements.
- The argument can be a C<DateTime> list, a C<DateTime::Span> list, a
- C<DateTime::Set>, or a C<DateTime::SpanSet>.
- ICal C<DATE> values are not supported. Whenever a date value is found,
- a C<DATE-TIME> is generated.
- If a recurrence has an associated C<DTSTART> or C<DTEND>, those values
- must be formatted using C<format_datetime()>. The
- C<format_recurrence()> method will not do this for you.
- If a C<union> or C<complement> of recurrences is being formatted, they
- are assumed to have the same C<DTSTART> value.
- Only C<union> and C<complement> operations are supported for
- recurrences. This is a limitation of the ICal specification.
- If given a set it cannot format, this method may die.
- Only C<DateTime::Set::ICal> objects are formattable. A set may change
- class after some set operations:
- $recurrence = $recurrence->union( $dt_set );
- # Ok - $recurrence still is a DT::Set::ICal
- $recurrence = $dt_set->union( $recurrence );
- # Not Ok! - $recurrence is a DT::Set now
- The only unbounded recurrences currently supported are the ones
- generated by the C<DateTime::Event::ICal> module.
- You can add ICal formatting support to a custom recurrence by using
- the C<DateTime::Set::ICal> module:
- $custom_recurrence =
- DateTime::Set::ICal->from_recurrence
- ( recurrence =>
- sub { $_[0]->truncate( to => 'month' )->add( months => 1 ) }
- );
- $custom_recurrence->set_ical( include => [ 'FREQ=MONTHLY' ] );
- =back
- =head1 SUPPORT
- Support for this module is provided via the datetime@perl.org email
- list. See http://lists.perl.org/ for more details.
- =head1 AUTHORS
- Dave Rolsky <autarch@urth.org> and Flavio Soibelmann Glock
- <fglock@pucrs.br>
- Some of the code in this module comes from Rich Bowen's C<Date::ICal>
- module.
- =head1 COPYRIGHT
- Copyright (c) 2003 David Rolsky. All rights reserved. This program
- is free software; you can redistribute it and/or modify it under the
- same terms as Perl itself.
- The full text of the license can be found in the LICENSE file included
- with this module.
- =head1 SEE ALSO
- datetime@perl.org mailing list
- http://datetime.perl.org/
- =cut