1# we need to comment this out or PAUSE might index it
2# pack age DateTime::Format::ICal;
3
4use strict;
5
6use DateTime;
7
8# Builder relevant stuff starts here.
9
10use DateTime::Format::Builder parsers => {
11    parse_datetime => [
12        [ preprocess => \&_parse_tz ],
13        {
14            length => 15,
15            params => [qw( year month day hour minute second )],
16            regex  => qr/^(\d\d\d\d)(\d\d)(\d\d)T(\d\d)(\d\d)(\d\d)$/,
17        },
18        {
19            length => 13,
20            params => [qw( year month day hour minute )],
21            regex  => qr/^(\d\d\d\d)(\d\d)(\d\d)T(\d\d)(\d\d)$/,
22        },
23        {
24            length => 11,
25            params => [qw( year month day hour )],
26            regex  => qr/^(\d\d\d\d)(\d\d)(\d\d)T(\d\d)$/,
27        },
28        {
29            length => 8,
30            params => [qw( year month day )],
31            regex  => qr/^(\d\d\d\d)(\d\d)(\d\d)$/,
32        },
33    ],
34};
35
36sub _parse_tz {
37    my %args = @_;
38    my ( $date, $p ) = @args{qw( input parsed )};
39    if ( $date =~ s/^TZID=([^:]+):// ) {
40        $p->{time_zone} = $1;
41    }
42
43    # Z at end means UTC
44    elsif ( $date =~ s/Z$// ) {
45        $p->{time_zone} = 'UTC';
46    }
47    else {
48        $p->{time_zone} = 'floating';
49    }
50    return $date;
51}
52
53# Builder relevant stuff ends here.
54
55sub parse_duration {
56    my ( $self, $dur ) = @_;
57
58    my @units = qw( weeks days hours minutes seconds );
59
60    $dur =~ m{ ([\+\-])?         # Sign
61               P                 # 'P' for period? This is our magic character)
62               (?:
63                   (?:(\d+)W)?   # Weeks
64                   (?:(\d+)D)?   # Days
65               )?
66               (?: T             # Time prefix
67                   (?:(\d+)H)?   # Hours
68                   (?:(\d+)M)?   # Minutes
69                   (?:(\d+)S)?   # Seconds
70               )?
71             }x;
72
73    my $sign = $1;
74
75    my %units;
76    $units{weeks}   = $2 if defined $2;
77    $units{days}    = $3 if defined $3;
78    $units{hours}   = $4 if defined $4;
79    $units{minutes} = $5 if defined $5;
80    $units{seconds} = $6 if defined $6;
81
82    die "Invalid ICal duration string ($dur)\n"
83        unless %units;
84
85    if ( $sign eq '-' ) {
86        $_ *= -1 foreach values %units;
87    }
88
89    return DateTime::Duration->new(%units);
90}
91
92sub format_datetime {
93    my ( $self, $dt ) = @_;
94
95    my $tz = $dt->time_zone;
96
97    unless ( $tz->is_floating || $tz->is_utc || $tz->name ) {
98        $dt = $dt->clone->set_time_zone('UTC');
99        $tz = $dt->time_zone;
100    }
101
102    my $base = (
103        $dt->hour || $dt->min || $dt->sec
104        ? sprintf(
105            '%04d%02d%02dT%02d%02d%02d',
106            $dt->year, $dt->month,  $dt->day,
107            $dt->hour, $dt->minute, $dt->second
108            )
109        : sprintf( '%04d%02d%02d', $dt->year, $dt->month, $dt->day )
110    );
111
112    return $base if $tz->is_floating;
113
114    return $base . 'Z' if $tz->is_utc;
115
116    return 'TZID=' . $tz->name . ':' . $base;
117}
118
119sub format_duration {
120    my ( $self, $duration ) = @_;
121
122    die "Cannot represent years or months in an iCal duration\n"
123        if $duration->delta_months;
124
125    # simple string for 0-length durations
126    return '+PT0S'
127        unless $duration->delta_days || $duration->delta_seconds;
128
129    my $ical = $duration->is_positive ? '+' : '-';
130    $ical .= 'P';
131
132    if ( $duration->delta_days ) {
133        $ical .= $duration->weeks . 'W' if $duration->weeks;
134        $ical .= $duration->days . 'D'  if $duration->days;
135    }
136
137    if ( $duration->delta_seconds ) {
138        $ical .= 'T';
139
140        $ical .= $duration->hours . 'H'   if $duration->hours;
141        $ical .= $duration->minutes . 'M' if $duration->minutes;
142        $ical .= $duration->seconds . 'S' if $duration->seconds;
143    }
144
145    return $ical;
146}
147
1481;
149