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