File Coverage

blib/lib/Net/CalDAVTalk.pm
Criterion Covered Total %
statement 88 1261 6.9
branch 1 788 0.1
condition 0 243 0.0
subroutine 25 82 30.4
pod 24 25 96.0
total 138 2399 5.7


line stmt bran cond sub pod time code
1             package Net::CalDAVTalk;
2              
3 2     2   83001 use 5.006;
  2         8  
4 2     2   10 use strict;
  2         3  
  2         51  
5 2     2   8 use warnings FATAL => 'all';
  2         6  
  2         79  
6              
7 2     2   557 use Net::DAVTalk;
  2         1044808  
  2         67  
8 2     2   17 use base qw(Net::DAVTalk);
  2         5  
  2         131  
9              
10 2     2   12 use Carp;
  2         4  
  2         125  
11 2     2   833 use Data::ICal;
  2         32904  
  2         21  
12 2     2   564 use Data::ICal::Entry::Event;
  2         669  
  2         17  
13 2     2   516 use Data::ICal::TimeZone;
  2         4436  
  2         20  
14 2     2   508 use Data::ICal::Entry::Alarm::Email;
  2         1178  
  2         20  
15 2     2   474 use Data::ICal::Entry::Alarm::Display;
  2         387  
  2         22  
16 2     2   624 use DateTime::Format::ICal;
  2         70824  
  2         25  
17 2     2   71 use DateTime::TimeZone;
  2         15  
  2         17  
18 2     2   47 use JSON::XS qw(encode_json);
  2         4  
  2         108  
19 2     2   3648 use Net::CalDAVTalk::TimeZones;
  2         28  
  2         39  
20 2     2   895 use Text::VCardFast qw(vcard2hash);
  2         4653  
  2         132  
21 2     2   13 use XML::Spice;
  2         4  
  2         16  
22 2     2   68 use MIME::Base64 qw(encode_base64);
  2         4  
  2         67  
23 2     2   481 use MIME::Types;
  2         5784  
  2         91  
24 2     2   623 use Digest::SHA qw(sha1_hex);
  2         3651  
  2         139  
25 2     2   13 use URI::Escape qw(uri_unescape);
  2         4  
  2         194  
26              
27             our $BATCHSIZE = 100;
28              
29             # monkey patch like a bandit
30             BEGIN {
31 2     2   11 my @properties = Data::ICal::Entry::Alarm::optional_unique_properties();
32 2         12 foreach my $want (qw(uid acknowledged)) {
33 4 50       9 push @properties, $want unless grep { $_ eq $want } @properties;
  10         24  
34             }
35 2     2   12 no warnings 'redefine';
  2         4  
  2         119  
36 2     0   1212 *Data::ICal::Entry::Alarm::optional_unique_properties = sub { @properties };
  0         0  
37             }
38              
39             our (
40             $DefaultCalendarColour,
41             $DefaultDisplayName,
42             );
43              
44             our $UTC = DateTime::TimeZone::UTC->new();
45             our $FLOATING = DateTime::TimeZone::Floating->new();
46             our $LOCALE = DateTime::Locale->load('en_US');
47              
48             # Beginning and End of time as used for "all event" date ranges
49             # Reducing this range may result in events disappearing from FastMail
50             # calendars, as we think they have been deleted from the other end,
51             # so best to avoid this.
52             # However, from my tests, the events should be resurrected once this date
53             # window includes them again.
54              
55             my $BoT = '1970-01-01T00:00:00';
56             my $EoT = '2038-01-19T00:00:00';
57              
58             my (
59             %WeekDayNames,
60             %WeekDayNamesReverse,
61             %DaysByName,
62             %DaysByIndex,
63             %ColourNames,
64             @Frequencies,
65             %RecurrenceProperties,
66             %UTCLinks,
67             %MustBeTopLevel,
68             %EventKeys,
69             );
70              
71             BEGIN {
72 2     2   24 %WeekDayNames = (
73             su => 'sunday',
74             mo => 'monday',
75             tu => 'tuesday',
76             we => 'wednesday',
77             th => 'thursday',
78             fr => 'friday',
79             sa => 'saturday',
80             );
81 2         12 %WeekDayNamesReverse = reverse %WeekDayNames;
82              
83 2         7 %DaysByName = (
84             su => 0,
85             mo => 1,
86             tu => 2,
87             we => 3,
88             th => 4,
89             fr => 5,
90             sa => 6,
91             );
92              
93 2         12 %DaysByIndex = reverse %DaysByName;
94 2         4 $DefaultCalendarColour = '#0252D4';
95 2         2 $DefaultDisplayName = 'Untitled Calendar';
96 2         6 @Frequencies = qw{yearly monthly weekly daily hourly minutely secondly};
97              
98 2         133 %EventKeys = (
99             '' => {
100             uid => [0, 'string', 1, undef],
101             relatedTo => [0, 'string', 0, undef],
102             prodId => [0, 'string', 0, undef],
103             created => [0, 'utcdate', 0, undef],
104             updated => [0, 'utcdate', 1, undef],
105             sequence => [0, 'number', 0, undef],
106             title => [0, 'string', 0, ''],
107             description => [0, 'string', 0, ''],
108             links => [0, 'object', 0, undef],
109             locale => [0, 'string', 0, undef],
110             localizations => [0, 'patch', 0, undef],
111             locations => [0, 'object', 0, undef],
112             isAllDay => [0, 'bool', 0, $JSON::false],
113             start => [0, 'localdate', 1, undef],
114             timeZone => [0, 'timezone', 0, undef],
115             duration => [0, 'duration', 0, undef],
116             recurrenceRule => [0, 'object', 0, undef],
117             recurrenceOverrides => [0, 'patch', 0, undef],
118             status => [0, 'string', 0, undef],
119             showAsFree => [0, 'bool', 0, undef],
120             replyTo => [0, 'object', 0, undef],
121             participants => [0, 'object', 0, undef],
122             useDefaultAlerts => [0, 'bool', 0, $JSON::false],
123             alerts => [0, 'object', 0, undef],
124             },
125             replyTo => {
126             imip => [0, 'mailto', 0, undef],
127             web => [0, 'href', 0, undef],
128             },
129             links => {
130             href => [0, 'string', 1, undef],
131             type => [0, 'string', 0, undef],
132             size => [0, 'number', 0, undef],
133             rel => [0, 'string', 1, undef],
134             title => [0, 'string', 1, undef],
135             properties => [0, 'string', 1, undef],
136             },
137             locations => {
138             name => [0, 'string', 0, undef],
139             accessInstructions => [0, 'string', 0, undef],
140             rel => [0, 'string', 0, 'unknown'],
141             timeZone => [0, 'timezone', 0, undef],
142             address => [0, 'object', 0, undef],
143             coordinates => [0, 'string', 0, undef],
144             uri => [0, 'string', 0, undef],
145             },
146             recurrenceRule => {
147             frequency => [0, 'string', 1, undef],
148             interval => [0, 'number', 0, undef],
149             rscale => [0, 'string', 0, 'gregorian'],
150             skip => [0, 'string', 0, 'omit'],
151             firstDayOfWeek => [0, 'string', 0, 'monday'],
152             byDay => [1, 'object', 0, undef],
153             byDate => [1, 'number', 0, undef],
154             byMonth => [1, 'string', 0, undef],
155             byYearDay => [1, 'number', 0, undef],
156             byWeekNo => [1, 'number', 0, undef],
157             byHour => [1, 'number', 0, undef],
158             byMinute => [1, 'number', 0, undef],
159             bySecond => [1, 'number', 0, undef],
160             bySetPosition => [1, 'number', 0, undef],
161             count => [0, 'number', 0, undef],
162             until => [0, 'localdate', 0, undef],
163             },
164             byDay => {
165             day => [0, 'string', 1, undef],
166             nthOfPeriod => [0, 'number', 0, undef],
167             },
168             participants => {
169             name => [0, 'string', 1, undef],
170             email => [0, 'string', 1, undef],
171             kind => [0, 'string', 0, 'unknown'],
172             roles => [1, 'string', 1, undef],
173             locationId => [0, 'string', 0, undef],
174             scheduleStatus => [0, 'string', 0, 'needs-action'],
175             schedulePriority => [0, 'string', 0, 'required'],
176             scheduleRSVP => [0, 'bool', 0, $JSON::false],
177             scheduleUpdated => [0, 'utcdate', 0, undef],
178             memberOf => [1, 'string', 0, undef],
179             },
180             alerts => {
181             relativeTo => [0, 'string', 0, 'before-start'],
182             offset => [0, 'duration', 1, undef],
183             action => [0, 'object', 1, undef],
184             },
185             action => {
186             type => [0, 'string', 1, undef],
187             },
188             );
189              
190 2         23 %RecurrenceProperties = (
191             bymonthday => {
192             name => 'byDate',
193             max => 31,
194             signed => 1,
195             },
196             byyearday => {
197             name => 'byYearDay',
198             max => 366,
199             signed => 1,
200             },
201             byweekno => {
202             name => 'byWeekNo',
203             max => 53,
204             signed => 1,
205             },
206             byhour => {
207             name => 'byHour',
208             max => 23,
209             },
210             byminute => {
211             name => 'byMinute',
212             max => 59,
213             },
214             bysecond => {
215             name => 'bySecond',
216             max => 60,
217             },
218             bysetpos => {
219             name => 'bySetPosition',
220             max => 366,
221             signed => 1,
222             },
223             );
224              
225 2         5 %MustBeTopLevel = map { $_ => 1 } qw{
  16         27  
226             uid
227             relatedTo
228             prodId
229             isAllDay
230             recurrenceRule
231             recurrenceOverrides
232             replyTo
233             participantId
234             };
235             # not in tc-api / JMAP, but necessary for iMIP
236 2         4 $MustBeTopLevel{method} = 1;
237              
238             # Colour names defined in CSS Color Module Level 3
239             # http://www.w3.org/TR/css3-color/
240              
241             %ColourNames
242 2         7 = map { $_ => 1 }
  294         464  
243             qw{
244             aliceblue
245             antiquewhite
246             aqua
247             aquamarine
248             azure
249             beige
250             bisque
251             black
252             blanchedalmond
253             blue
254             blueviolet
255             brown
256             burlywood
257             cadetblue
258             chartreuse
259             chocolate
260             coral
261             cornflowerblue
262             cornsilk
263             crimson
264             cyan
265             darkblue
266             darkcyan
267             darkgoldenrod
268             darkgray
269             darkgreen
270             darkgrey
271             darkkhaki
272             darkmagenta
273             darkolivegreen
274             darkorange
275             darkorchid
276             darkred
277             darksalmon
278             darkseagreen
279             darkslateblue
280             darkslategray
281             darkslategrey
282             darkturquoise
283             darkviolet
284             deeppink
285             deepskyblue
286             dimgray
287             dimgrey
288             dodgerblue
289             firebrick
290             floralwhite
291             forestgreen
292             fuchsia
293             gainsboro
294             ghostwhite
295             gold
296             goldenrod
297             gray
298             green
299             greenyellow
300             grey
301             honeydew
302             hotpink
303             indianred
304             indigo
305             ivory
306             khaki
307             lavender
308             lavenderblush
309             lawngreen
310             lemonchiffon
311             lightblue
312             lightcoral
313             lightcyan
314             lightgoldenrodyellow
315             lightgray
316             lightgreen
317             lightgrey
318             lightpink
319             lightsalmon
320             lightseagreen
321             lightskyblue
322             lightslategray
323             lightslategrey
324             lightsteelblue
325             lightyellow
326             lime
327             limegreen
328             linen
329             magenta
330             maroon
331             mediumaquamarine
332             mediumblue
333             mediumorchid
334             mediumpurple
335             mediumseagreen
336             mediumslateblue
337             mediumspringgreen
338             mediumturquoise
339             mediumvioletred
340             midnightblue
341             mintcream
342             mistyrose
343             moccasin
344             navajowhite
345             navy
346             oldlace
347             olive
348             olivedrab
349             orange
350             orangered
351             orchid
352             palegoldenrod
353             palegreen
354             paleturquoise
355             palevioletred
356             papayawhip
357             peachpuff
358             peru
359             pink
360             plum
361             powderblue
362             purple
363             red
364             rosybrown
365             royalblue
366             saddlebrown
367             salmon
368             sandybrown
369             seagreen
370             seashell
371             sienna
372             silver
373             skyblue
374             slateblue
375             slategray
376             slategrey
377             snow
378             springgreen
379             steelblue
380             tan
381             teal
382             thistle
383             tomato
384             turquoise
385             violet
386             wheat
387             white
388             whitesmoke
389             yellow
390             yellowgreen
391             };
392              
393 2         11474 %UTCLinks = (
394             'Etc/GMT-0' => 1,
395             'Etc/GMT+0' => 1,
396             'Etc/GMT0' => 1,
397             'Etc/GMT' => 1,
398             'Etc/Greenwich' => 1,
399             'Etc/UCT' => 1,
400             'Etc/Universal' => 1,
401             'Etc/UTC' => 1,
402             'Etc/Zulu' => 1,
403             'GMT' => 1,
404             'UCT' => 1,
405             'UTC' => 1,
406             );
407             }
408              
409              
410             =head1 NAME
411              
412             Net::CalDAVTalk - Module to talk CalDAV and give a JSON interface to the data
413              
414             =head1 VERSION
415              
416             Version 0.11
417              
418             =cut
419              
420             our $VERSION = '0.11';
421              
422              
423             =head1 SYNOPSIS
424              
425             This module is the initial release of the code used at FastMail for talking
426             to CalDAV servers. It's quite specific to an early version of our API, so
427             while it might be useful to others, it's being pushed to CPAN more because
428             the Cassandane test suite needs it.
429              
430             See Net::DAVTalk for details on how to specify hosts and paths.
431              
432             my $CalDAV = Net::CalDAVTalk->new(
433             user => $service->user(),
434             password => $service->pass(),
435             host => $service->host(),
436             port => $service->port(),
437             scheme => 'http',
438             url => '/',
439             expandurl => 1,
440             );
441              
442             or using DNS:
443              
444             my $domain = $user;
445             $domain =~ s/.*\@//;
446              
447             my $url;
448             my ($reply) = $Resolver->search("_caldavs._tcp.$domain", "srv");
449             if ($reply) {
450             my @d = $reply->answer;
451             if (@d) {
452             my $host = $d[0]->target();
453             my $port = $d[0]->port();
454             $url = "https://$host";
455             $url .= ":$port" unless $port eq 443;
456             }
457             }
458              
459             This will use the '/.well-known/caldav' address to find the actual current user
460             principal, and from there the calendar-home-set for further operations.
461              
462             my $foo = Net::CalDAVTalk->new(
463             user => $user,
464             password => $password,
465             url => $url,
466             expandurl => 1,
467             );
468              
469              
470             =head1 SUBROUTINES/METHODS
471              
472             =head2 new(%args)
473              
474             Takes the same arguments as Net::DAVTalk and adds the caldav namespaces
475             and some Cyrus specific namespaces for all XML requests.
476              
477             A => 'http://apple.com/ns/ical/'
478             C => 'urn:ietf:params:xml:ns:caldav'
479             CY => 'http://cyrusimap.org/ns/'
480             UF => 'http://cyrusimap.org/ns/userflag/'
481             SF => 'http://cyrusimap.org/ns/sysflag/'
482              
483             =cut
484              
485             sub new {
486 0     0 1   my ($Class, %Params) = @_;
487              
488 0           $Params{homesetns} = 'C';
489 0           $Params{homeset} = 'calendar-home-set';
490 0           $Params{wellknown} = 'caldav';
491              
492 0           my $Self = $Class->SUPER::new(%Params);
493              
494 0           $Self->ns(A => 'http://apple.com/ns/ical/');
495 0           $Self->ns(C => 'urn:ietf:params:xml:ns:caldav');
496 0           $Self->ns(CY => 'http://cyrusimap.org/ns/');
497 0           $Self->ns(UF => 'http://cyrusimap.org/ns/userflag/');
498 0           $Self->ns(SF => 'http://cyrusimap.org/ns/sysflag/');
499              
500 0           return $Self;
501             }
502              
503             =head2 $self->tz($name)
504              
505             Returns a DateTime::TimeZone object for the given name, but caches
506             the result for speed.
507              
508             =cut
509              
510             sub tz {
511 0     0 1   my $Self = shift;
512 0           my $tzName = shift;
513 0 0         return $FLOATING unless defined $tzName;
514 0 0         return $UTC if $UTCLinks{$tzName};
515 0 0         unless (exists $Self->{_tz}{$tzName}) {
516 0           $Self->{_tz}{$tzName} = DateTime::TimeZone->new(name => $tzName);
517             }
518 0           return $Self->{_tz}{$tzName};
519             }
520              
521             =head2 $self->logger(sub { })
522              
523             Sets a function to receive all log messages. Gets called with the first
524             argument being a level name, and then a list of items to log:
525              
526             e.g.
527              
528             $CalDAV->logger(sub {
529             my $level = shift;
530             return if ($level eq 'debug' and not $ENV{DEBUG_CALDAV});
531             warn "LOG $level: $_\n" for @_;
532             });
533              
534             =cut
535              
536             sub logger {
537 0     0 1   my $Self = shift;
538              
539 0 0         if ($@) {
540 0           $Self->{logger} = shift;
541             }
542              
543 0           return $Self->{logger};
544             }
545              
546             =head2 $self->DeleteCalendar($calendarId)
547              
548             Delete the named calendar from the server (shorturl - see Net::DAVTalk)
549              
550             =cut
551              
552             =head2 $Cal->DeleteCalendar($calendarId)
553              
554             Delete the calendar with collection name $calendarId (full or relative path)
555              
556             e.g.
557              
558             $Cal->DeleteCalendar('Default');
559              
560             =cut
561              
562             sub DeleteCalendar {
563 0     0 1   my ($Self, $calendarId) = @_;
564              
565 0 0         unless ($calendarId) {
566 0           confess 'Calendar not specified';
567             }
568              
569             $Self->Request(
570 0           'DELETE',
571             "$calendarId/",
572             );
573              
574 0           return 1;
575             }
576              
577             sub _fixColour {
578 0   0 0     my $color = lc(shift || '');
579              
580 0 0         return $color if $ColourNames{$color};
581 0 0         return $DefaultCalendarColour unless $color =~ m/^\s*(\#[a-f0-9]{3,8})\s*$/;
582 0           $color = $1;
583 0 0         return uc($color) if length($color) == 7;
584              
585             # Optional digit is for transparency (RGBA)
586 0 0         if ( $color =~ m/^#(.)(.)(.).?$/ ) {
587 0           return uc "#$1$1$2$2$3$3";
588             }
589              
590             # Last two digits are for transparency (RGBA)
591 0 0         if ( length($color) == 9 ) {
592 0           return uc(substr($color,0,7));
593             }
594              
595 0           return $DefaultCalendarColour;
596             }
597              
598              
599             =head2 $self->GetCalendar($calendarId)
600              
601             Get a single calendar from the server by calendarId
602             (currently implemented very inefficiently as a get
603             of all calendars. Returns undef if the calendar
604             doesn't exist.
605              
606             e.g
607             my $Calendar = $CalDAV->GetCalendar('Default');
608              
609             =cut
610              
611             sub GetCalendar {
612 0     0 1   my ($Self, $CalendarId) = @_;
613 0           my $Calendars = $Self->GetCalendars();
614 0 0 0       die "No calendars" unless ($Calendars and @$Calendars);
615 0           my ($Calendar) = grep { $_->{id} eq $CalendarId } @$Calendars;
  0            
616 0           return $Calendar;
617             }
618              
619             =head2 $self->GetCalendars(Properties => [])
620              
621             Fetch all the calendars on the server. You can request additional
622             properties, but they aren't parsed well yet.
623              
624             e.g
625              
626             my $Calendars = $CalDAV->GetCalendars();
627             foreach my $Cal (@$Calendars) {
628             # do stuff
629             }
630              
631             =cut
632              
633             sub GetCalendars {
634 0     0 1   my ($Self, %Args) = @_;
635              
636             # XXX To generalise for CPAN:
637             # XXX - the PROPFIND should be D:allprop unless $Args{Properties} is set
638             # XXX - return all properties as object attributes without renaming
639             # XXX - translate property names to our own liking within ME::CalDAV
640              
641 0           my %Properties = map { $_ => 1 } (
642             'D:displayname',
643             'D:resourcetype',
644             'A:calendar-color',
645             'D:current-user-privilege-set',
646             'D:acl',
647             'A:calendar-order',
648             'C:calendar-timezone',
649             'D:sync-token',
650             'D:supported-report-set',
651             'C:supported-calendar-data',
652 0 0         @{$Args{Properties} || []},
  0            
653             );
654              
655             my $Response = $Self->Request(
656             'PROPFIND',
657             '',
658             x('D:propfind', $Self->NS(),
659             x('D:prop',
660 0           map { x($_) } keys %Properties,
  0            
661             ),
662             ),
663             Depth => 1,
664             );
665              
666 0           my @Calendars;
667              
668 0           my $NS_A = $Self->ns('A');
669 0           my $NS_C = $Self->ns('C');
670 0           my $NS_CY = $Self->ns('CY');
671 0           my $NS_D = $Self->ns('D');
672 0 0         foreach my $Response (@{$Response->{"{$NS_D}response"} || []}) {
  0            
673 0 0         next unless $Response->{"{$NS_D}href"}{content};
674 0           my $href = uri_unescape($Response->{"{$NS_D}href"}{content});
675              
676             # grab the short version of the path
677 0           my $calendarId = $Self->shortpath($href);
678             # and remove trailing slash always
679 0           $calendarId =~ s{/$}{};
680              
681 0 0         foreach my $Propstat (@{$Response->{"{$NS_D}propstat"} || []}) {
  0            
682 0 0         next unless $Propstat->{"{$NS_D}prop"}{"{$NS_D}resourcetype"}{"{$NS_C}calendar"};
683              
684             # XXX - this should be moved into ME::CalDAV::GetCalendars()
685 0           my $visData = $Propstat->{"{$NS_D}prop"}{"{$NS_C}X-FM-isVisible"}{content};
686 0 0 0       my $isVisible = (not defined($visData) or $visData) ? $JSON::true : $JSON::false;
687              
688 0           my %Privileges = (
689             mayAdmin => $JSON::false,
690             mayWrite => $JSON::false,
691             mayRead => $JSON::false,
692             mayReadFreeBusy => $JSON::false,
693             );
694              
695 0           my $Priv = $Propstat->{"{$NS_D}prop"}{"{$NS_D}current-user-privilege-set"}{"{$NS_D}privilege"};
696 0 0 0       $Priv = [] unless ($Priv and ref($Priv) eq 'ARRAY');
697 0           foreach my $item (@$Priv) {
698 0 0         $Privileges{'mayAdmin'} = $JSON::true if $item->{"{$NS_CY}admin"};
699 0 0         $Privileges{'mayWrite'} = $JSON::true if $item->{"{$NS_D}write-content"};
700 0 0         $Privileges{'mayRead'} = $JSON::true if $item->{"{$NS_D}read"};
701 0 0         $Privileges{'mayReadFreeBusy'} = $JSON::true if $item->{"{$NS_C}read-free-busy"};
702             }
703              
704 0           my $CanEvent;
705 0           my $Type = $Propstat->{"{$NS_D}prop"}{"{$NS_C}supported-calendar-data"}{"{$NS_C}calendar-data"};
706 0 0 0       $Type = [] unless ($Type and ref($Type) eq 'ARRAY');
707 0           foreach my $item (@$Type) {
708 0 0         next unless $item->{"\@content-type"};
709 0 0         $CanEvent = 1 if $item->{"\@content-type"}{content} eq "application/event+json";
710             }
711              
712             # XXX - temporary compat
713 0 0         $Privileges{isReadOnly} = $Privileges{mayWrite} ? $JSON::false : $JSON::true;
714              
715 0           my @ShareWith;
716 0           my $ace = $Propstat->{"{$NS_D}prop"}{"{$NS_D}acl"}{"{$NS_D}ace"};
717 0 0 0       $ace = [] unless ($ace and ref($ace) eq 'ARRAY');
718 0           foreach my $Acl (@$ace) {
719 0 0         next if $Acl->{"{$NS_D}protected"}; # ignore admin ACLs
720 0 0         next unless $Acl->{"{$NS_D}grant"};
721 0 0         next unless $Acl->{"{$NS_D}grant"}{"{$NS_D}privilege"};
722 0 0         next unless ref($Acl->{"{$NS_D}grant"}{"{$NS_D}privilege"}) eq 'ARRAY';
723             # XXX - freeBusyPublic here? Or should we do it via the web server?
724 0   0       my $user = uri_unescape($Acl->{"{$NS_D}principal"}{"{$NS_D}href"}{content} // '');
725 0 0         next unless $user =~ m{^/dav/principals/user/([^/]+)};
726 0           my $email = $1;
727 0 0         next if $email eq 'admin';
728 0           my %ShareObject = (
729             email => $email,
730             mayAdmin => $JSON::false,
731             mayWrite => $JSON::false,
732             mayRead => $JSON::false,
733             mayReadFreeBusy => $JSON::false,
734             );
735 0           foreach my $item (@{$Acl->{"{$NS_D}grant"}{"{$NS_D}privilege"}}) {
  0            
736 0 0         $ShareObject{'mayAdmin'} = $JSON::true if $item->{"{$NS_CY}admin"};
737 0 0         $ShareObject{'mayWrite'} = $JSON::true if $item->{"{$NS_D}write-content"};
738 0 0         $ShareObject{'mayRead'} = $JSON::true if $item->{"{$NS_D}read"};
739 0 0         $ShareObject{'mayReadFreeBusy'} = $JSON::true if $item->{"{$NS_C}read-free-busy"};
740             }
741              
742 0           push @ShareWith, \%ShareObject;
743             }
744              
745             my %Cal = (
746             id => $calendarId,
747             name => ($Propstat->{"{$NS_D}prop"}{"{$NS_D}displayname"}{content} || $DefaultDisplayName),
748             href => $href,
749             color => _fixColour($Propstat->{"{$NS_D}prop"}{"{$NS_A}calendar-color"}{content}),
750             timeZone => $Propstat->{"{$NS_D}prop"}{"{$NS_C}calendar-timezone"}{content},
751             isVisible => $isVisible,
752             precedence => int($Propstat->{"{$NS_D}prop"}{"{$NS_A}calendar-order"}{content} || 1),
753 0 0 0       syncToken => ($Propstat->{"{$NS_D}prop"}{"{$NS_D}sync-token"}{content} || ''),
    0 0        
      0        
754             shareWith => (@ShareWith ? \@ShareWith : $JSON::false),
755             _can_event => ($CanEvent ? $JSON::true : $JSON::false),
756             %Privileges,
757             );
758              
759              
760 0           push @Calendars, \%Cal;
761             }
762             }
763              
764 0           return \@Calendars;
765             }
766              
767             =head2 $self->NewCalendar($Args)
768              
769             Create a new calendar. The Args are the as the things returned by GetCalendars,
770             except that if you don't provide 'id' (same as shorturl), then a UUID will be
771             generated for you. It's recommended to not provide 'id' unless you need to
772             create a specific path for compatibility with other things, and to use 'name'
773             to identify the calendar for users. 'name' is stored as DAV:displayname.
774              
775             e.g.
776              
777             my $Id = $CalDAV->NewCalendar({name => 'My Calendar', color => 'aqua'});
778              
779             (Color names will be translated based on the CSS name list)
780              
781             =cut
782              
783             sub NewCalendar {
784 0     0 1   my ($Self, $Args) = @_;
785              
786 0 0         unless (ref($Args) eq 'HASH') {
787 0           confess 'Invalid calendar';
788             }
789              
790             # The URL should be "/$calendarId/" but this isn't true with Zimbra (Yahoo!
791             # Calendar). It will accept a MKCALENDAR at "/$calendarId/" but will rewrite
792             # the calendar's URL to be "/$HTMLEscapedDisplayName/". I'm sure MKCALENDAR
793             # should follow WebDAV's MKCOL method here, but it's not specified in CalDAV.
794              
795             # default values
796 0   0       $Args->{id} //= $Self->genuuid();
797 0   0       $Args->{name} //= $DefaultDisplayName;
798              
799 0           my $calendarId = $Args->{id};
800              
801 0           my @Properties;
802              
803 0           push @Properties, x('D:displayname', $Args->{name});
804              
805 0 0         if (exists $Args->{isVisible}) {
806 0 0         push @Properties, x('C:X-FM-isVisible', ($Args->{isVisible} ? 1 : 0));
807             }
808              
809 0 0         if (exists $Args->{color}) {
810 0           push @Properties, x('A:calendar-color', _fixColour($Args->{color}));
811             }
812              
813 0 0         if (exists $Args->{timeZone}) {
814 0           push @Properties, x('C:calendar-timezone', $Args->{timeZone});
815             }
816              
817 0 0         if (exists $Args->{precedence}) {
818 0 0 0       unless (($Args->{precedence} // '') =~ /^\d+$/) {
819 0           confess "Invalid precedence ($Args->{precedence}) (expected int >= 0)";
820             }
821              
822 0           push @Properties, x('A:calendar-order', $Args->{precedence});
823             }
824              
825             $Self->Request(
826 0           'MKCALENDAR',
827             "$calendarId/",
828             x('C:mkcalendar', $Self->NS(),
829             x('D:set',
830             x('D:prop', @Properties),
831             ),
832             ),
833             );
834              
835 0           return $calendarId;
836             }
837              
838             =head2 $self->UpdateCalendar($Args)
839              
840             Like 'NewCalendar', but updates an existing calendar, and 'id' is required.
841             Returns the id, just like NewCalendar.
842              
843             =cut
844              
845             sub UpdateCalendar {
846 0     0 1   my ($Self, $Args, $Prev) = @_;
847              
848 0 0         unless (ref($Args) eq 'HASH') {
849 0           confess 'Invalid calendar';
850             }
851              
852 0           my %Calendar = %{$Args};
  0            
853 0           my $calendarId = $Calendar{id};
854              
855 0 0         unless ($calendarId) {
856 0           confess 'Calendar not specified';
857             }
858              
859 0           my @Params;
860              
861 0 0         if (defined $Calendar{name}) {
862 0           push @Params, x('D:displayname', $Calendar{name});
863             }
864              
865 0 0         if (defined $Calendar{color}) {
866 0           push @Params, x('A:calendar-color', _fixColour($Calendar{color}));
867             }
868              
869 0 0         if (exists $Args->{timeZone}) {
870 0           push @Params, x('C:calendar-timezone', $Args->{timeZone});
871             }
872              
873 0 0         if (exists $Calendar{isVisible}) {
874 0 0         push @Params, x('C:X-FM-isVisible', $Calendar{isVisible} ? 1 : 0);
875             }
876              
877 0 0         if (exists $Calendar{precedence}) {
878 0 0 0       unless (($Calendar{precedence} ||'') =~ /^\d+$/) {
879 0           confess "Invalid precedence ($Calendar{precedence})";
880             }
881              
882 0           push @Params, x('A:calendar-order', $Calendar{precedence});
883             }
884              
885 0 0         return $calendarId unless @Params;
886              
887 0           $Self->Request(
888             'PROPPATCH',
889             "$calendarId/",
890             x('D:propertyupdate', $Self->NS(),
891             x('D:set',
892             x('D:prop',
893             @Params,
894             ),
895             ),
896             ),
897             );
898              
899 0           return $calendarId;
900             }
901              
902             # Event methods
903              
904             =head2 $self->DeleteEvent($Event|$href)
905              
906             Given a single event or the href to the event, delete that event,
907             delete it from the server.
908              
909             Returns true.
910              
911             =cut
912              
913             sub DeleteEvent {
914 0     0 1   my ($Self) = shift;
915 0           my ($Event) = @_;
916              
917 0 0         confess "Need an event" unless $Event;
918              
919 0 0         $Event = { href => $Event, summary => $Event } unless ref($Event) eq 'HASH';
920              
921             $Self->Request(
922             'DELETE',
923             $Event->{href},
924 0           );
925              
926 0           return 1;
927             }
928              
929             =head2 $self->GetEvents($calendarId, %Args)
930              
931             Fetches some or all of the events in a calendar.
932              
933             Supported args:
934              
935             href => [] - perform a multi-get on just these fullpath urls.
936             after+before => ISO8601 - date range to query
937              
938             In scalar context returns an arrayref of events. In list context
939             returns both an arrayref of events and an arrayref of errors:
940              
941             e.g.
942              
943             my ($Events, $Errors) = $CalDAV->GetEvents('Default');
944              
945             =cut
946              
947             sub GetEvents {
948 0     0 1   my ($Self, $calendarId, %Args) = @_;
949              
950 0           my $urls = $Self->GetEventLinks($calendarId, %Args);
951              
952 0           my @AllUrls = sort keys %$urls;
953              
954 0           my ($Events, $Errors, $Links) = $Self->GetEventsMulti($calendarId, \@AllUrls, %Args);
955              
956 0 0         return wantarray ? ($Events, $Errors, $Links) : $Events;
957             }
958              
959             =head2 $self->GetEventsMulti($calendarId, $Urls, %Args)
960              
961             Fetches the events in Urs from the calendar
962              
963             Supported args:
964              
965             * ContentType
966             * Version
967              
968             For the calendar-data response
969              
970             In scalar context returns an arrayref of events. In list context
971             returns an array of:
972              
973             * arrayref of events
974             * arrayref of errors:
975             * hash of href to getetag
976              
977             =cut
978              
979             sub GetEventsMulti {
980 0     0 1   my ($Self, $calendarId, $Urls, %Args) = @_;
981              
982 0 0         confess "Need a calendarId" unless $calendarId;
983              
984 0           my @Annotations;
985 0   0       my $AnnotNames = $Args{Annotations} || [];
986 0           foreach my $key (@$AnnotNames) {
987 0 0         my $name = ($key =~ m/:/ ? $key : "C:$key");
988 0           push @Annotations, x($name);
989             }
990              
991 0           my %CalProps;
992 0 0         if ($Args{ContentType}) {
993 0           $CalProps{'content-type'} = $Args{ContentType};
994             }
995 0 0         if ($Args{Version}) {
996 0           $CalProps{'version'} = $Args{Version};
997             }
998              
999 0           my (@Events, @Errors, %Links);
1000              
1001 0           while (my @urls = splice(@$Urls, 0, $BATCHSIZE)) {
1002             my $Response = $Self->Request(
1003             'REPORT',
1004             "$calendarId/",
1005             x('C:calendar-multiget', $Self->NS(),
1006             x('D:prop',
1007             x('C:calendar-data', \%CalProps),
1008             x('D:getetag'),
1009             @Annotations,
1010             ),
1011 0           map { x('D:href', $_) } @urls,
  0            
1012              
1013             ),
1014             Depth => 1,
1015             );
1016              
1017 0           my $NS_A = $Self->ns('A');
1018 0           my $NS_C = $Self->ns('C');
1019 0           my $NS_D = $Self->ns('D');
1020 0 0         foreach my $Response (@{$Response->{"{$NS_D}response"} || []}) {
  0            
1021 0   0       my $href = uri_unescape($Response->{"{$NS_D}href"}{content} // '');
1022 0 0         next unless $href;
1023 0 0         foreach my $Propstat (@{$Response->{"{$NS_D}propstat"} || []}) {
  0            
1024 0           my $etag = $Propstat->{"{$NS_D}prop"}{"{$NS_D}getetag"}{content};
1025 0           $Links{$href} = $etag;
1026 0           my $Prop = $Propstat->{"{$NS_D}prop"}{"{$NS_C}calendar-data"};
1027 0           my $Data = $Prop->{content};
1028 0 0         next unless $Data;
1029              
1030 0           my $Event;
1031              
1032 0 0 0       if ($Prop->{'-content-type'} and $Prop->{'-content-type'} =~ m{application/event\+json}) {
1033             # JSON event is in API format already
1034 0           $Event = eval { decode_json($Data) };
  0            
1035             }
1036             else {
1037             # returns an array, but there should only be one UID per file
1038 0           ($Event) = eval { $Self->vcalendarToEvents($Data) };
  0            
1039             }
1040              
1041 0 0         if ($@) {
1042 0           push @Errors, $@;
1043 0           next;
1044             }
1045 0 0         next unless $Event;
1046              
1047 0 0         if ($Args{Full}) {
1048 0           $Event->{_raw} = $Data;
1049             }
1050              
1051 0           $Event->{href} = $href;
1052 0           $Event->{id} = $Self->shortpath($href);
1053              
1054 0           foreach my $key (@$AnnotNames) {
1055 0           my $propns = $NS_C;
1056 0           my $name = $key;
1057 0 0         if ($key =~ m/(.*):(.*)/) {
1058 0           $name = $2;
1059 0           $propns = $Self->ns($1);
1060             }
1061 0           my $AData = $Propstat->{"{$NS_D}prop"}{"{$propns}$name"}{content};
1062 0 0         next unless $AData;
1063 0           $Event->{annotation}{$name} = $AData;
1064             }
1065              
1066 0           push @Events, $Event;
1067             }
1068             }
1069             }
1070              
1071 0 0         return wantarray ? (\@Events, \@Errors, \%Links) : \@Events;
1072             }
1073              
1074             =head2 $self->GetEventLinks($calendarId, %Args)
1075              
1076             Fetches the URLs of calendar events in a calendar.
1077              
1078             Supported args:
1079              
1080             after+before => ISO8601 - date range to query
1081              
1082             returns a hash of href to etag
1083              
1084             =cut
1085              
1086             sub GetEventLinks {
1087 0     0 1   my ($Self, $calendarId, %Args) = @_;
1088 0 0         confess "Need a calendarId" unless $calendarId;
1089              
1090 0           my @Extra;
1091 0 0 0       if ($Args{AlwaysRange} || $Args{after} || $Args{before}) {
      0        
1092 0   0       my $Start = _wireDate($Args{after} || $BoT);
1093 0   0       my $End = _wireDate($Args{before} || $EoT);
1094 0           push @Extra, x('C:time-range', {
1095             start => $Start->strftime('%Y%m%dT000000Z'),
1096             end => $End->strftime('%Y%m%dT000000Z'),
1097             });
1098             }
1099              
1100 0           my $Response = $Self->Request(
1101             'REPORT',
1102             "$calendarId/",
1103             x('C:calendar-query', $Self->NS(),
1104             x('D:prop',
1105             x('D:getetag'),
1106             ),
1107             x('C:filter',
1108             x('C:comp-filter', { name => 'VCALENDAR' },
1109             x('C:comp-filter', { name => 'VEVENT' },
1110             @Extra,
1111             ),
1112             ),
1113             ),
1114             ),
1115             Depth => 1,
1116             );
1117              
1118 0           my (%Links, @Errors);
1119              
1120 0           my $NS_A = $Self->ns('A');
1121 0           my $NS_C = $Self->ns('C');
1122 0           my $NS_D = $Self->ns('D');
1123 0 0         foreach my $Response (@{$Response->{"{$NS_D}response"} || []}) {
  0            
1124 0   0       my $href = uri_unescape($Response->{"{$NS_D}href"}{content} // '');
1125 0 0         next unless $href;
1126 0 0         foreach my $Propstat (@{$Response->{"{$NS_D}propstat"} || []}) {
  0            
1127 0           my $etag = $Propstat->{"{$NS_D}prop"}{"{$NS_D}getetag"}{content};
1128 0           $Links{$href} = $etag;
1129             }
1130             }
1131              
1132 0           return \%Links;
1133             }
1134              
1135             =head2 $self->GetEvent($href)
1136              
1137             Just get a single event (calls GetEvents with that href)
1138              
1139             =cut
1140              
1141             sub GetEvent {
1142 0     0 1   my ($Self, $href, %Args) = @_;
1143              
1144             # XXX - API
1145 0           my $calendarId = $href;
1146 0           $calendarId =~ s{/[^/]*$}{};
1147              
1148 0           my ($Events, $Errors) = $Self->GetEventsMulti($calendarId, [$Self->fullpath($href)], %Args);
1149              
1150 0 0         die "Errors @$Errors" if @$Errors;
1151 0 0         die "Multiple items returned for $href" if @$Events > 1;
1152              
1153 0           return $Events->[0];
1154             }
1155              
1156             =head2 $self->GetFreeBusy($calendarId, %Args)
1157              
1158             Like 'GetEvents' but uses a free-busy-query and then generates
1159             synthetic events out of the result.
1160              
1161             Doesn't have a 'href' parameter, just the before/after range.
1162              
1163             =cut
1164              
1165             sub GetFreeBusy {
1166 0     0 1   my ($Self, $calendarId, %Args) = @_;
1167              
1168             # validate parameters {{{
1169              
1170 0 0         confess "Need a calendarId" unless $calendarId;
1171              
1172 0           my @Query;
1173 0 0 0       if ($Args{AlwaysRange} || $Args{after} || $Args{before}) {
      0        
1174 0   0       my $Start = _wireDate($Args{after} || $BoT);
1175 0   0       my $End = _wireDate($Args{before} || $EoT);
1176              
1177 0           push @Query,
1178             x('C:time-range', {
1179             start => $Start->strftime('%Y%m%dT000000Z'),
1180             end => $End->strftime('%Y%m%dT000000Z'),
1181             });
1182             }
1183              
1184             # }}}
1185              
1186 0           my $Response = $Self->Request(
1187             'REPORT',
1188             "$calendarId/",
1189             x('C:free-busy-query', $Self->NS(),
1190             @Query,
1191             ),
1192             Depth => 1,
1193             );
1194              
1195 0 0         my $Data = eval { vcard2hash($Response->{content}, multival => ['rrule'], only_one => 1) }
  0            
1196             or confess "Error parsing VFreeBusy data: $@";
1197              
1198 0           my @result;
1199             my @errors;
1200 0           my $now = DateTime->now();
1201 0           foreach my $item (@{$Data->{objects}[0]{objects}}) {
  0            
1202 0 0         next unless $item->{type} eq 'vfreebusy';
1203 0           foreach my $line (@{$item->{properties}{freebusy}}) {
  0            
1204 0           my ($Start, $End) = split '/', $line->{value};
1205 0           my ($StartTime, $IsAllDay) = $Self->_makeDateObj($Start, 'UTC', 'UTC');
1206 0           my $EndTime;
1207 0 0         if ($End =~ m/^[+-]?P/i) {
1208 0   0       my $Duration = eval { DateTime::Format::ICal->parse_duration(uc $End) }
1209             || next;
1210 0           $EndTime = $StartTime->clone()->add($Duration);
1211             } else {
1212 0           ($EndTime) = $Self->_makeDateObj($End, 'UTC', 'UTC');
1213             }
1214 0           my $duration = $Self->_make_duration($EndTime->subtract_datetime($StartTime));
1215             my $NewEvent = {
1216             timeZone => 'Etc/UTC',
1217             start => $StartTime->iso8601(),
1218             duration => $duration,
1219 0 0 0       title => ($Args{name} // ''),
1220             isAllDay => ($IsAllDay ? $JSON::true : $JSON::false),
1221             updated => $now->iso8601(),
1222             };
1223              
1224             # Generate a uid that should remain the same for this freebusy entry
1225 0           $NewEvent->{uid} = _hexkey($NewEvent) . '-freebusyauto';
1226             $NewEvent->{isAllDay} =
1227 0 0         $NewEvent->{isAllDay} ? $JSON::true : $JSON::false;
1228 0           push @result, $NewEvent;
1229             }
1230             }
1231              
1232 0           warn Dumper(\@result);
1233 0           return (\@result, \@errors);
1234             }
1235              
1236             =head2 $self->SyncEvents($calendarId, %Args)
1237              
1238             Like GetEvents, but if you pass a syncToken argument, then it will
1239             fetch changes since that token (obtained from an earlier GetCalendars
1240             call).
1241              
1242             In scalar context still just returns new events, in list context returns
1243             Events, Removed and Errors.
1244              
1245             e.g.
1246              
1247             my ($Events, $Removed, $Errors) = $CalDAV->SyncEvents('Default', syncToken => '...');
1248              
1249             =cut
1250              
1251             sub SyncEvents {
1252 0     0 1   my ($Self, $calendarId, %Args) = @_;
1253              
1254 0           my ($Added, $Removed, $Errors, $SyncToken) = $Self->SyncEventLinks($calendarId, %Args);
1255              
1256 0           my @AllUrls = sort keys %$Added;
1257              
1258 0           my ($Events, $ThisErrors, $Links) = $Self->GetEventsMulti($calendarId, \@AllUrls, %Args);
1259 0           push @$Errors, @$ThisErrors;
1260              
1261 0 0         return wantarray ? ($Events, $Removed, $Errors, $SyncToken, $Links) : $Events;
1262             }
1263              
1264             sub SyncEventLinks {
1265 0     0 0   my ($Self, $calendarId, %Args) = @_;
1266              
1267 0 0         confess "Need a calendarId" unless $calendarId;
1268              
1269             my $Response = $Self->Request(
1270             'REPORT',
1271             "$calendarId/",
1272             x('D:sync-collection', $Self->NS(),
1273 0 0         x('D:sync-token', ($Args{syncToken} ? ($Args{syncToken}) : ())),
1274             x('D:sync-level', 1),
1275             x('D:prop',
1276             x('D:getetag'),
1277             ),
1278             ),
1279             );
1280              
1281 0           my $NS_A = $Self->ns('A');
1282 0           my $NS_C = $Self->ns('C');
1283 0           my $NS_D = $Self->ns('D');
1284              
1285 0           my $SyncToken = $Response->{"{$NS_D}sync-token"}{content};
1286 0 0         confess "NO SYNC TOKEN RETURNED " . Dumper($Response) unless $SyncToken;
1287              
1288 0           my (%Added, @Removed, @Errors);
1289 0 0         foreach my $Response (@{$Response->{"{$NS_D}response"} || []}) {
  0            
1290 0   0       my $href = uri_unescape($Response->{"{$NS_D}href"}{content} // '');
1291 0 0         next unless $href;
1292              
1293 0 0         unless ($Response->{"{$NS_D}propstat"}) {
1294 0           push @Removed, $href;
1295 0           next;
1296             }
1297              
1298 0 0         foreach my $Propstat (@{$Response->{"{$NS_D}propstat"} || []}) {
  0            
1299 0           my $status = $Propstat->{"{$NS_D}status"}{content};
1300 0 0         if ($status =~ m/ 200 /) {
1301 0           my $etag = $Propstat->{"{$NS_D}prop"}{"{$NS_D}getetag"}{content};
1302 0           $Added{$href} = $etag;
1303             }
1304             else {
1305 0           push @Errors, "Odd status $status";
1306             }
1307             }
1308             }
1309              
1310 0           return (\%Added, \@Removed, \@Errors, $SyncToken);
1311             }
1312              
1313             =head2 $self->NewEvent($calendarId, $Args)
1314              
1315             Create a new event in the named calendar. If you don't specify 'uid' then
1316             a UUID will be created. You should only specify the UID if you need to for
1317             syncing purposes - it's better to auto-generate otherwise.
1318              
1319             Returns the href, but also updates 'uid' in $Args.
1320              
1321             Also updates 'sequence'.
1322              
1323             e.g.
1324              
1325             my $href = $CalDAV->NewEvent('Default', $Args);
1326             my $newuid = $Args->{uid};
1327              
1328             =cut
1329              
1330             sub NewEvent {
1331 0     0 1   my ($Self, $calendarId, $Args) = @_;
1332              
1333 0 0         confess "Need a calendarId" unless $calendarId;
1334              
1335 0 0         confess "invalid event" unless ref($Args) eq 'HASH';
1336              
1337 0           my $UseEvent = delete $Args->{_put_event_json};
1338              
1339             # calculate updated sequence numbers
1340 0 0         unless (exists $Args->{sequence}) {
1341 0           $Args->{sequence} = 1;
1342             }
1343              
1344 0 0         if ($Args->{exceptions}) {
1345 0           foreach my $recurrenceId (sort keys %{$Args->{exceptions}}) {
  0            
1346 0           my $val = $Args->{exceptions}{$recurrenceId};
1347 0 0         next unless $val;
1348 0 0         next if exists $val->{sequence};
1349              
1350 0           $val->{sequence} = $Args->{sequence};
1351             }
1352             }
1353              
1354 0   0       $Args->{uid} //= $Self->genuuid();
1355 0           my $uid = $Args->{uid};
1356 0           my $path = $uid;
1357 0           $path =~ tr/[a-zA-Z0-9\@\.\_\-]//cd;
1358 0           my $href = "$calendarId/$path.ics";
1359              
1360 0 0         if ($UseEvent) {
1361 0           $Self->Request(
1362             'PUT',
1363             $href,
1364             encode_json($Args),
1365             'Content-Type' => 'application/event+json',
1366             );
1367             }
1368             else {
1369 0           my $VCalendar = $Self->_argsToVCalendar($Args);
1370 0           $Self->Request(
1371             'PUT',
1372             $href,
1373             $VCalendar->as_string(),
1374             'Content-Type' => 'text/calendar',
1375             );
1376             }
1377              
1378 0           return $href;
1379             }
1380              
1381             =head2 $self->UpdateEvent($href, $Args)
1382              
1383             Like NewEvent, but you only need to specify keys that you want to change,
1384             and it takes the full href to the card instead of the containing calendar.
1385              
1386             =cut
1387              
1388             sub UpdateEvent {
1389 0     0 1   my ($Self, $href, $Args) = @_;
1390              
1391 0           my $UseEvent = delete $Args->{_put_event_json};
1392              
1393 0           my ($OldEvent, $NewEvent) = $Self->_updateEvent($href, $Args);
1394              
1395 0 0         if ($UseEvent) {
1396 0           $Self->Request(
1397             'PUT',
1398             $href,
1399             encode_json($NewEvent),
1400             'Content-Type' => 'application/event+json',
1401             );
1402             }
1403             else {
1404 0           my $VCalendar = $Self->_argsToVCalendar($NewEvent);
1405 0           $Self->Request(
1406             'PUT',
1407             $href,
1408             $VCalendar->as_string(),
1409             'Content-Type' => 'text/calendar',
1410             );
1411             }
1412              
1413 0           return 1;
1414             }
1415              
1416             sub _updateEvent {
1417 0     0     my ($Self, $href, $Args) = @_;
1418              
1419 0           my $OldEvent = $Self->GetEvent($href);
1420              
1421 0 0         confess "Error getting old event for $href"
1422             unless $OldEvent;
1423              
1424 0           my %NewEvent;
1425              
1426 0           foreach my $Property (keys %EventKeys) {
1427 0 0         if (exists $Args->{$Property}) {
    0          
1428 0 0         if (defined $Args->{$Property}) {
1429 0           $NewEvent{$Property} = $Args->{$Property};
1430             }
1431             }
1432             elsif (exists $OldEvent->{$Property}) {
1433 0           $NewEvent{$Property} = $OldEvent->{$Property};
1434             }
1435             }
1436              
1437             # calculate updated sequence numbers
1438 0 0         unless (exists $Args->{sequence}) {
1439 0   0       $NewEvent{sequence} = ($OldEvent->{sequence} || 0) + 1;
1440             }
1441              
1442 0 0         if ($NewEvent{exceptions}) {
1443 0           foreach my $recurrenceId (sort keys %{$NewEvent{exceptions}}) {
  0            
1444 0           my $val = $NewEvent{exceptions}{$recurrenceId};
1445 0 0         next unless $val;
1446 0 0         next if exists $val->{sequence};
1447              
1448 0           my $old = $OldEvent->{exceptions}{$recurrenceId};
1449 0           my $sequence = $NewEvent{sequence};
1450 0 0 0       if ($old && exists $old->{sequence}) {
1451 0 0         $sequence = $old->{sequence} + 1 unless $sequence > $old->{sequence};
1452             }
1453 0           $val->{sequence} = $sequence;
1454             }
1455             }
1456              
1457 0           $NewEvent{href} = $href;
1458              
1459 0           return ($OldEvent, \%NewEvent);
1460             }
1461              
1462             =head2 $self->AnnotateEvent($href, $Args)
1463              
1464             Instead of actually changing an event itself, use proppatch to
1465             add or remove properties on the event.
1466              
1467             =cut
1468              
1469             sub AnnotateEvent {
1470 0     0 1   my ($Self, $href, $Args) = @_;
1471              
1472 0           my $OldEvent = $Self->GetEvent($href);
1473              
1474 0 0         confess "Error getting old event for $href"
1475             unless $OldEvent;
1476              
1477 0           my @Set;
1478             my @Remove;
1479 0           foreach my $key (sort keys %$Args) {
1480 0 0         my $name = ($key =~ m/:/ ? $key : "C:$key");
1481 0 0         if (defined $Args->{$key}) {
1482 0           push @Set, x($name, $Args->{$key});
1483             }
1484             else {
1485 0           push @Remove, x($name);
1486             }
1487             }
1488              
1489 0           my @Params;
1490 0 0         push @Params, x('D:set', x('D:prop', @Set)) if @Set;
1491 0 0         push @Params, x('D:remove', x('D:prop', @Remove)) if @Remove;
1492 0 0         return undef unless @Params;
1493              
1494 0           $Self->Request(
1495             'PROPPATCH',
1496             $href,
1497             x('D:propertyupdate', $Self->NS(), @Params),
1498             );
1499              
1500 0           return 1;
1501             }
1502              
1503             =head2 $self->MoveEvent($href, $newCalendarId)
1504              
1505             Move an event into a new calendar. Returns the new href.
1506              
1507             =cut
1508              
1509             sub MoveEvent {
1510 0     0 1   my ($Self, $href, $newCalendarId) = @_;
1511              
1512 0           my $OldEvent = $Self->GetEvent($href);
1513              
1514 0 0         return unless $OldEvent;
1515              
1516 0           my $dest = $href;
1517 0           $dest =~ s{.*/}{$newCalendarId/};
1518 0 0         return if $href eq $dest;
1519              
1520 0           $Self->Request(
1521             'MOVE',
1522             $href,
1523             undef,
1524             'Destination' => $Self->fullpath($dest),
1525             );
1526              
1527 0           warn "CAL: MoveEvent $Self->{user} ($href => $dest)\n";
1528              
1529 0           return $dest;
1530             }
1531              
1532             sub _BYDAY2byDay {
1533 0     0     my ($BYDAY) = @_;
1534              
1535 0           my ($Count, $Day) = $BYDAY =~ /^([-+]?\d+)?(\w\w)$/;
1536              
1537 0 0         unless ($Day) {
1538 0           confess 'Recurrence BYDAY-weekday not specified';
1539             }
1540              
1541 0 0         unless ($WeekDayNames{$Day}) {
1542 0           confess 'Invalid recurrence BYDAY-weekday';
1543             }
1544              
1545 0 0         if ($Count) {
1546 0 0 0       unless (($Count >= -53) and ($Count <= 53)) {
1547 0           confess 'Recurrence BYDAY-ordwk is out of range';
1548             }
1549             }
1550              
1551             return {
1552 0 0         day => $WeekDayNames{$Day},
1553             $Count ? (nthOfPeriod => int($Count)) : (),
1554             };
1555             }
1556              
1557             sub _byDay2BYDAY {
1558 0     0     my ($byDay) = @_;
1559              
1560 0 0         unless (defined $byDay) {
1561 0           confess 'Invalid recurrence byDay';
1562             }
1563              
1564 0 0         unless (ref $byDay eq 'HASH') {
1565 0           confess 'Recurrence byDay is not an object';
1566             }
1567              
1568 0           my $Day = $WeekDayNamesReverse{$byDay->{day}};
1569 0 0         unless ($Day) {
1570 0           confess 'Recurrence byDay is not a known day';
1571             }
1572 0           my $Prefix = '';
1573 0 0         $Prefix = int($byDay->{nthOfPeriod}) if $byDay->{nthOfPeriod};
1574              
1575 0           return $Prefix . uc($Day);
1576             }
1577              
1578             sub _makeDateObj {
1579 0     0     my $Self = shift;
1580 0           my $DateStr = shift;
1581 0           my $TZStr = shift;
1582 0           my $TargetTz = shift;
1583              
1584 0           my ($Date, $HasTime) = _vDate($DateStr);
1585              
1586             # if it's all day, return it immediately
1587 0 0         return ($Date, 1) unless $HasTime;
1588              
1589             # Do the timezone manipulation as required
1590 0 0         $Date->set_time_zone($Self->tz($TZStr)) if $TZStr;
1591 0 0         $Date->set_time_zone($Self->tz($TargetTz)) if $TargetTz;
1592              
1593 0           return ($Date, 0);
1594             }
1595              
1596             sub _getDateObj {
1597 0     0     my $Self = shift;
1598 0           my $Calendar = shift;
1599 0           my $VItem = shift;
1600 0           my $TargetTz = shift;
1601              
1602 0           my $TimeZone = $Self->_getTimeZone($Calendar, $VItem);
1603 0           my ($Date, $IsAllDay) = $Self->_makeDateObj($VItem->{value}, $TimeZone, $TargetTz);
1604              
1605 0 0         return (wantarray ? ($Date, $TimeZone, $IsAllDay) : $Date);
1606             }
1607              
1608             sub _getDateObjMulti {
1609 0     0     my $Self = shift;
1610 0           my $Calendar = shift;
1611 0           my $VItem = shift;
1612 0           my $TargetTz = shift;
1613              
1614 0           my @Dates;
1615              
1616 0           my $TimeZone = $Self->_getTimeZone($Calendar, $VItem);
1617 0           foreach my $Value (split /,/, $VItem->{value}) {
1618             # XXX - handle $V2 sanely
1619 0 0 0       if (lc($VItem->{params}{value}[0] || '') eq 'period') {
1620 0           ($Value, my $V2) = split /\//, $Value;
1621             }
1622 0           my ($Date, $IsAllDay) = $Self->_makeDateObj($Value, $TimeZone, $TargetTz);
1623 0           push @Dates, $Date;
1624             }
1625              
1626 0           return @Dates;
1627             }
1628              
1629             # Exclude DTSTAMP from auto uid generation
1630             sub _hexkey {
1631 0     0     my $VEvent = shift;
1632 0           my $updated = delete $VEvent->{properties}->{updated};
1633 0           my $d = Data::Dumper->new([$VEvent]);
1634 0           $d->Indent(0);
1635 0           $d->Sortkeys(1);
1636 0           my $Key = sha1_hex($d->Dump());
1637 0 0         $VEvent->{properties}->{updated} = $updated if defined $updated;
1638 0           return $Key;
1639             }
1640              
1641             sub _saneuid {
1642 0     0     my $uid = shift;
1643 0 0         return unless $uid;
1644 0 0         return if $uid =~ m/\s/;
1645 0 0         return if $uid =~ m/[\x7f-\xff]/;
1646             # any other sanity checks?
1647 0           return 1;
1648             }
1649              
1650             sub _makeParticipant {
1651 0     0     my ($Self, $Calendar, $Participants, $VAttendee, $role) = @_;
1652              
1653 0           my $id = $VAttendee->{value};
1654 0 0         return unless $id;
1655 0           $id =~ s/^mailto://i;
1656 0 0         return if $id eq '';
1657              
1658 0   0       $Participants->{$id} ||= {};
1659              
1660             # XXX - if present on one but not the other, take the "best" version
1661 0   0       $Participants->{$id}{name} = $VAttendee->{params}{"cn"}[0] // "";
1662 0           $Participants->{$id}{email} = $id;
1663             $Participants->{$id}{kind} = lc $VAttendee->{params}{"cutype"}[0]
1664 0 0         if $VAttendee->{params}{"cutype"};
1665 0           push @{$Participants->{$id}{roles}}, $role;
  0            
1666             # we don't support locationId yet
1667 0 0         if ($VAttendee->{params}{"partstat"}) {
1668 0   0       $Participants->{$id}{scheduleStatus} = lc($VAttendee->{params}{"partstat"}[0] // "needs-action");
1669             }
1670 0 0         if ($VAttendee->{params}{"role"}) {
1671 0           push @{$Participants->{$id}{roles}}, 'chair'
1672 0 0         if uc $VAttendee->{params}{"role"}[0] eq 'CHAIR';
1673             $Participants->{$id}{schedulePriority} = 'optional'
1674 0 0         if uc $VAttendee->{params}{"role"}[0] eq 'OPT-PARTICIPANT';
1675             $Participants->{$id}{schedulePriority} = 'non-participant'
1676 0 0         if uc $VAttendee->{params}{"role"}[0] eq 'NON-PARTICIPANT';
1677             }
1678 0 0         if ($VAttendee->{params}{"rsvp"}) {
1679 0 0 0       $Participants->{$id}{scheduleRSVP} = lc($VAttendee->{params}{"rsvp"}[0] // "") eq 'yes' ? $JSON::true : $JSON::false;
1680             }
1681 0 0         if (exists $VAttendee->{params}{"x-dtstamp"}) {
1682 0           my ($Date) = eval { $Self->_makeDateObj($VAttendee->{params}{"x-dtstamp"}[0], 'UTC', 'UTC') };
  0            
1683 0 0         $Participants->{$id}{"scheduleUpdated"} = $Date->iso8601() . 'Z' if $Date;
1684             }
1685             # memberOf is not supported
1686              
1687 0 0         if (exists $VAttendee->{params}{"x-sequence"}) {
1688 0   0       $Participants->{$id}{"x-sequence"} = $VAttendee->{params}{"x-sequence"}[0] // "";
1689             }
1690             }
1691              
1692             sub _make_duration {
1693 0     0     my ($Self, $dtdur, $IsAllDay) = @_;
1694              
1695 0           my ($w, $d, $H, $M, $S) = (
1696             $dtdur->weeks,
1697             $dtdur->days,
1698             $dtdur->hours,
1699             $dtdur->minutes,
1700             $dtdur->seconds,
1701             );
1702              
1703 0 0 0       return 'PT0S' unless ($w || $d || $H || $M || $S);
      0        
      0        
      0        
1704              
1705 0           my @bits = ('P');
1706 0 0         push @bits, ($w, 'W') if $w;
1707 0 0         push @bits, ($d, 'D') if $d;
1708 0 0 0       if (not $IsAllDay and ($H || $M || $S)) {
      0        
1709 0           push @bits, 'T';
1710 0 0         push @bits, ($H, 'H') if $H;
1711 0 0         push @bits, ($M, 'M') if $M;
1712 0 0         push @bits, ($S, 'S') if $S;
1713             }
1714              
1715 0           return join ('', @bits);
1716             }
1717              
1718             =head2 $NewEvent = Net::CalDAVTalk->NormaliseEvent($Event);
1719              
1720             Doesn't change the original event, but removes any keys which are the same as their default value
1721              
1722             =cut
1723              
1724             sub NormaliseEvent {
1725 0     0 1   my ($class, $Event, $Root) = @_;
1726              
1727 0   0       $Root ||= '';
1728              
1729 0           my %Copy = %$Event;
1730              
1731             # XXX: patches need to be normalised as well...
1732 0           my $Spec = $EventKeys{$Root};
1733 0           foreach my $key (keys %$Event) {
1734 0 0         delete $Copy{$key} unless $Spec->{$key};
1735             }
1736 0           foreach my $key (sort keys %$Spec) {
1737             # remove if it's the default
1738 0 0         if ($Spec->{$key}[1] eq 'object') {
    0          
    0          
1739 0           my $Item = delete $Copy{$key};
1740 0 0         next unless $Item; # no object
1741 0 0         if ($Spec->{$key}[0]) {
1742 0           $Copy{$key} = [map { $class->NormaliseEvent($_, $key) } @$Item];
  0            
1743             }
1744             else {
1745 0           $Copy{$key} = $class->NormaliseEvent($Item, $key);
1746             }
1747             }
1748             elsif ($Spec->{$key}[1] eq 'bool') {
1749 0 0         delete $Copy{$key} if !!$Spec->{$key}[3] == !!$Copy{$key};
1750             }
1751             elsif ($Spec->{$key}[1] eq 'mailto') {
1752 0 0         $Copy{$key} = lc $Copy{$key} if $Copy{$key};
1753             }
1754             else {
1755 0 0         delete $Copy{$key} if _safeeq($Spec->{$key}[3], $Copy{$key});
1756             }
1757             }
1758              
1759 0           return \%Copy;
1760             }
1761              
1762             =head2 Net::CalDAVTalk->CompareEvents($Event1, $Event2);
1763              
1764             Returns true if the events are identical
1765              
1766             =cut
1767              
1768             sub CompareEvents {
1769 0     0 1   my ($class, $Event1, $Event2) = @_;
1770              
1771 0           my $E1 = $class->NormaliseEvent($Event1);
1772 0           my $E2 = $class->NormaliseEvent($Event2);
1773              
1774 0           return _safeeq($E1, $E2);
1775             }
1776              
1777              
1778             sub _getEventsFromVCalendar {
1779 0     0     my ($Self, $VCalendar) = @_;
1780              
1781 0 0         my $CalendarData = eval { vcard2hash($VCalendar, multival => ['rrule'], only_one => 1) }
  0            
1782             or confess "Error parsing VCalendar data: $@\n\n$VCalendar";
1783              
1784 0           my @Events;
1785              
1786 0 0         foreach my $Calendar (@{$CalendarData->{objects} || []}) {
  0            
1787 0 0         next unless lc $Calendar->{type} eq 'vcalendar';
1788              
1789 0           my $method = $Calendar->{properties}{method}[0]{value};
1790 0           my $prodid = $Calendar->{properties}{prodid}[0]{value};
1791              
1792 0 0         foreach my $VEvent (@{$Calendar->{objects} || []}) {
  0            
1793 0 0         next unless lc $VEvent->{type} eq 'vevent';
1794              
1795             # parse simple component properties {{{
1796              
1797             my %Properties
1798 0           = map { $_ => $VEvent->{properties}{$_}[0] }
1799 0           keys %{$VEvent->{properties}};
  0            
1800              
1801 0           my $uid = $Properties{uid}{value};
1802             # Case: UID is badly broken or missing -
1803             # let's just calculate a UID based on the incoming data. This
1804             # is the 'ICS sync url with no UIDs in it' case from BTS-3205,
1805             # http://mozorg.cdn.mozilla.net/media/caldata/DutchHolidays.ics
1806 0 0         $uid = _hexkey($VEvent) . '-syncauto' unless _saneuid($uid);
1807              
1808 0   0       my $ShowAsFree = (lc($Properties{transp}{value} || '')) eq 'transparent';
1809              
1810             # clean up whitespace on text fields
1811 0           foreach my $Property (qw{description location summary}) {
1812 0 0         next unless defined $Properties{$Property}{value};
1813 0           $Properties{$Property}{value} =~ s/^\s+//gs;
1814 0           $Properties{$Property}{value} =~ s/\s+$//gs;
1815             }
1816              
1817 0           my @description;
1818             push @description, $Properties{description}{value}
1819 0 0         if defined $Properties{description}{value};
1820              
1821             # }}}
1822              
1823             # parse time component properties {{{
1824              
1825 0           my ($IsAllDay, $Start, $StartTimeZone, $End, $EndTimeZone) = ('') x 5;
1826              
1827 0 0         confess "$uid: DTSTART not specified" unless defined $Properties{dtstart}{value};
1828              
1829 0           ($Start, $StartTimeZone, $IsAllDay) = $Self->_getDateObj($Calendar, $Properties{dtstart});
1830              
1831 0 0         if (defined $Properties{dtend}{value}) {
    0          
1832 0 0         if (defined $Properties{duration}{value}) {
1833 0           warn "$uid: DTEND and DURATION cannot both be set";
1834             }
1835              
1836 0           ($End, $EndTimeZone) = $Self->_getDateObj($Calendar, $Properties{dtend});
1837             }
1838             elsif (defined $Properties{duration}{value}) {
1839 0           my $Duration = DateTime::Format::ICal->parse_duration(uc $Properties{duration}{value});
1840 0           $End = $Start->clone()->add($Duration);
1841 0           $EndTimeZone = $StartTimeZone;
1842             }
1843             else {
1844 0           $End = $Start->clone();
1845 0           $EndTimeZone = $StartTimeZone;
1846             }
1847              
1848 0 0         if (DateTime->compare($Start, $End) > 0) {
1849             # swap em!
1850 0           ($Start, $End) = ($End, $Start);
1851 0           ($StartTimeZone, $EndTimeZone) = ($EndTimeZone, $StartTimeZone);
1852             }
1853              
1854 0 0 0       if ($IsAllDay and $StartTimeZone) {
1855 0           warn "$uid: AllDay event with timezone $StartTimeZone specified";
1856             }
1857              
1858             # if one is set, make sure they are both set
1859 0   0       $StartTimeZone ||= $EndTimeZone;
1860 0   0       $EndTimeZone ||= $StartTimeZone;
1861              
1862             # }}}
1863              
1864 0           my %Recurrence;
1865              
1866 0 0         if (exists $Properties{rrule}) {
1867 0           my %RRULE;
1868              
1869 0           foreach my $RRULE (@{$Properties{rrule}{values}}) {
  0            
1870 0           my ($Key,$Value) = split '=', $RRULE;
1871 0 0         next unless defined $Value;
1872              
1873 0           $RRULE{lc $Key} = $Value;
1874             }
1875              
1876             # parse simple recurrence properties {{{
1877              
1878 0 0         if (exists $RRULE{freq}) {
1879 0           my $freq = lc $RRULE{freq};
1880 0 0         unless (grep { $_ eq $freq } @Frequencies) {
  0            
1881 0           confess "$uid: Invalid recurrence FREQ ($RRULE{freq})";
1882             }
1883              
1884 0           $Recurrence{frequency} = $freq;
1885             }
1886             else {
1887 2     2   20 use Data::Dumper;
  2         4  
  2         11776  
1888 0           confess "$uid: Recurrence FREQ not specified";
1889             }
1890              
1891 0 0         if (exists $RRULE{interval}) {
1892 0 0         unless ($RRULE{interval} =~ /^\d+$/) {
1893 0           confess "$uid: Invalid recurrence INTERVAL ($RRULE{interval})";
1894             }
1895 0           my $interval = int $RRULE{interval};
1896              
1897 0 0         if ($interval == 0) {
1898 0           confess "$uid: Recurrence INTERVAL is out of range ($RRULE{interval})";
1899             }
1900              
1901             # default == 1, so don't set a key for it
1902 0 0         if ($interval > 1) {
1903 0           $Recurrence{interval} = $interval;
1904             }
1905             }
1906              
1907 0 0         if (exists $RRULE{rscale}) {
1908 0           $Recurrence{rscale} = lc $RRULE{rscale};
1909 0 0         $Recurrence{skip} = lc $RRULE{skip} if $RRULE{skip};
1910             }
1911              
1912 0 0         if (exists $RRULE{wkst}) {
1913 0           my $wkst = lc $RRULE{wkst};
1914 0 0         unless ($WeekDayNames{$wkst}) {
1915 0           confess "$uid: Invalid recurrence WKST ($RRULE{wkst})";
1916             }
1917              
1918             # default is Monday, so don't set a key for it
1919 0 0         if ($wkst ne 'mo') {
1920 0           $Recurrence{firstDayOfWeek} = $WeekDayNames{$wkst};
1921             }
1922             }
1923              
1924 0 0         if (exists $RRULE{byday}) {
1925 0           my @byDays;
1926              
1927 0           foreach my $BYDAY (split ',', $RRULE{byday}) {
1928 0           push @byDays, _BYDAY2byDay(lc $BYDAY);
1929             }
1930              
1931 0 0         $Recurrence{byDay} = \@byDays if @byDays;
1932             }
1933              
1934 0 0         if (exists $RRULE{bymonth}) {
1935 0           foreach my $BYMONTH (split ',', $RRULE{bymonth}) {
1936 0 0         unless ($BYMONTH =~ /^\d+L?$/) {
1937 0           confess "$uid: Invalid recurrence BYMONTH ($BYMONTH, $RRULE{bymonth})";
1938             }
1939              
1940 0           push @{$Recurrence{byMonth}}, "$BYMONTH";
  0            
1941             }
1942             }
1943              
1944 0 0         if (exists $RRULE{count}) {
1945 0 0         if (exists $RRULE{until}) {
1946             #confess "$uid: Recurrence COUNT and UNTIL cannot both be set";
1947             # seen in the wild: PRODID:-//dmfs.org//mimedir.icalendar//EN
1948 0           delete $RRULE{until};
1949             }
1950              
1951 0 0         unless ($RRULE{count} =~ /^\d+$/) {
1952 0           confess "$uid: Invalid recurrence COUNT ($RRULE{count})";
1953             }
1954              
1955 0           $Recurrence{count} = int $RRULE{count};
1956             }
1957              
1958 0 0         if (exists $RRULE{until}) {
1959             # rfc5545 3.3.10 - UNTIL must be in DTSTART timezone, but both
1960             # google and iCloud store it in Z, so we will too as per rfc2445.
1961 0           my ($Until, $IsAllDay) = $Self->_makeDateObj($RRULE{until}, $StartTimeZone, $StartTimeZone);
1962 0           $Recurrence{until} = $Until->iso8601();
1963             }
1964              
1965             # }}}
1966              
1967             # parse generic recurrence properties {{{
1968              
1969 0           foreach my $Property (keys %RecurrenceProperties) {
1970 0 0         if (defined $RRULE{$Property}) {
1971 0           foreach my $Value (split ',', $RRULE{$Property}) {
1972             my ($Valid, $Min) = $RecurrenceProperties{$Property}{signed}
1973 0 0         ? ('[-+]?[1-9]\d*', ($RecurrenceProperties{$Property}{max} * -1))
1974             : ('\d+', 0);
1975              
1976 0 0         unless ($Value =~ /^$Valid$/) {
1977 0           confess "$uid: Invalid recurrence $Property ($Value)";
1978             }
1979              
1980 0 0 0       unless (($Value >= $Min) and ($Value <= $RecurrenceProperties{$Property}{max})) {
1981 0           confess "$uid: Recurrence $Property is out of range ($Value)";
1982             }
1983              
1984 0           push @{$Recurrence{$RecurrenceProperties{$Property}{name}}}, int $Value;
  0            
1985             }
1986             }
1987             }
1988              
1989             # }}}
1990             }
1991              
1992 0           my %Overrides;
1993 0 0         if (exists $VEvent->{properties}{exdate}) {
1994 0           foreach my $Item (@{$VEvent->{properties}{exdate}}) {
  0            
1995 0           foreach my $Date ($Self->_getDateObjMulti($Calendar, $Item, $StartTimeZone)) {
1996 0           $Overrides{$Date->iso8601()} = $JSON::null;
1997             }
1998             }
1999             }
2000              
2001 0 0         if ($VEvent->{properties}{rdate}) {
2002             # rdate = "RDATE" rdtparam ":" rdtval *("," rdtval) CRLF
2003 0           foreach my $Item (@{$VEvent->{properties}{rdate}}) {
  0            
2004 0           foreach my $Date ($Self->_getDateObjMulti($Calendar, $Item, $StartTimeZone)) {
2005 0           $Overrides{$Date->iso8601()} = {};
2006             }
2007             }
2008             }
2009              
2010             # parse alarms {{{
2011              
2012 0           my %Alerts;
2013 0 0         foreach my $VAlarm (@{$VEvent->{objects} || []}) {
  0            
2014 0 0         next unless lc $VAlarm->{type} eq 'valarm';
2015              
2016             my %AlarmProperties
2017 0           = map { $_ => $VAlarm->{properties}{$_}[0] }
2018 0           keys %{$VAlarm->{properties}};
  0            
2019              
2020 0   0       my $alarmuid = $AlarmProperties{uid}{value} || _hexkey($VAlarm) . '-alarmauto';
2021              
2022 0           my %Alert;
2023              
2024 0           my $AlarmAction = lc $AlarmProperties{action}{value};
2025 0 0         next unless $AlarmAction;
2026              
2027 0           my %Action;
2028              
2029 0 0         if ($AlarmAction eq 'display') {
    0          
    0          
    0          
    0          
2030 0           $Action{type} = 'display';
2031             }
2032             elsif ($AlarmAction eq 'email') {
2033 0           $Action{type} = 'email';
2034              
2035             $Action{to} = [
2036 0           map { my ($x) = $_->{value} =~ m/^(?:mailto:)?(.*)/i; { email => $x } }
  0            
2037 0   0       @{$VAlarm->{properties}{attendee} // []}
  0            
2038             ];
2039             }
2040             elsif ($AlarmAction eq 'uri') {
2041 0           $Action{type} = 'uri';
2042 0   0       $Action{uri} = $VAlarm->{properties}{uri} // [];
2043             }
2044             elsif ($AlarmAction eq 'audio') {
2045             # audio alerts aren't the same as popups, but for now...
2046 0           $Action{type} = 'display';
2047             }
2048             elsif ($AlarmAction eq 'none') {
2049 0           next;
2050             }
2051             else {
2052 0           warn "$uid: UNKNOWN VALARM ACTION $AlarmAction";
2053 0           next;
2054             }
2055              
2056 0 0         if ($AlarmProperties{acknowledged}) {
2057 0           my $date = $Self->_getDateObj($Calendar, $AlarmProperties{acknowledged}, 'UTC');
2058 0           $Action{acknowledged} = $date->iso8601() . 'Z';
2059             }
2060              
2061             my $Trigger = $AlarmProperties{trigger}{value}
2062 0   0       || next;
2063              
2064 0 0 0       my $Related = (lc ($AlarmProperties{trigger}{params}{related}[0] || '') eq 'end')
2065             ? 'end'
2066             : 'start';
2067              
2068 0           my $Duration;
2069 0 0         if ($Trigger =~ m/^[+-]?P/i) {
2070 0   0       $Duration = eval { DateTime::Format::ICal->parse_duration(uc $Trigger) }
2071             || next;
2072              
2073             } else {
2074 0           my $AlertDate = $Self->_getDateObj($Calendar, $AlarmProperties{trigger}, $StartTimeZone);
2075 0 0         $Duration = $AlertDate->subtract_datetime($Related eq 'end' ? $End : $Start);
2076             }
2077              
2078 0 0         if ($Duration->is_negative()) {
2079 0           $Duration = $Duration->inverse();
2080 0           $Alert{relativeTo} = "before-$Related";
2081             }
2082             else {
2083 0           $Alert{relativeTo} = "after-$Related";
2084             }
2085              
2086 0           $Alert{action} = \%Action;
2087 0           $Alert{offset} = $Self->_make_duration($Duration);
2088              
2089 0           $Alerts{$alarmuid} = \%Alert;
2090             }
2091              
2092             # }}}
2093              
2094             # parse attendees {{{
2095              
2096 0           my %Participants;
2097 0 0         for my $VOrganizer (@{$VEvent->{properties}{organizer} || []}) {
  0            
2098 0           $Self->_makeParticipant($Calendar, \%Participants, $VOrganizer, 'owner');
2099             }
2100 0 0         for my $VAttendee (@{$VEvent->{properties}{attendee} || []}) {
  0            
2101 0           $Self->_makeParticipant($Calendar, \%Participants, $VAttendee, 'attendee');
2102             }
2103              
2104             # }}}
2105              
2106             # parse attachments {{{
2107              
2108 0           my %Links;
2109 0 0         foreach my $Attach (@{$VEvent->{properties}{attach} || []}) {
  0            
2110 0 0         next unless $Attach->{value};
2111 0 0         next unless grep { $Attach->{value} =~ m{^$_://} } qw{http https ftp};
  0            
2112              
2113 0           my $uri = $Attach->{value};
2114 0           my $filename = $Attach->{params}{filename}[0];
2115             # XXX - mime guessing?
2116 0           my $mime = $Attach->{params}{fmttype}[0];
2117 0 0         if (not defined $mime) {
2118 0   0       $::MimeTypes ||= MIME::Types->new;
2119 0           my $MimeTypeObj = $::MimeTypes->mimeTypeOf($filename);
2120 0 0         $mime = $MimeTypeObj->type() if $MimeTypeObj;
2121             }
2122              
2123 0           my $size = $Attach->{params}{size}[0];
2124              
2125 0 0         $Links{$uri} = {
    0          
    0          
2126             href => $uri,
2127             rel => 'enclosure',
2128             defined $filename ? (title => $filename) : (),
2129             defined $mime ? (type => $mime) : (),
2130             defined $size ? (size => 0+$size) : (),
2131             };
2132             }
2133 0 0         foreach my $URL (@{$VEvent->{properties}{url} || []}) {
  0            
2134 0           my $uri = $URL->{value};
2135 0 0         next unless $uri;
2136 0           $Links{$uri} = { href => $uri };
2137             }
2138              
2139             # }}}
2140              
2141             # ============= Metadata
2142 0           my %Event = (uid => $uid);
2143             # no support for relatedTo yet
2144 0           $Event{prodId} = $prodid;
2145 0 0         if ($Properties{created}{value}) {
2146             # UTC item
2147 0           my $Date = eval { $Self->_getDateObj($Calendar, $Properties{created}, 'UTC') };
  0            
2148 0 0         $Event{created} = $Date->iso8601() . 'Z' if $Date;
2149             }
2150 0 0         if ($Properties{dtstamp}{value}) {
2151             # UTC item
2152 0           my $Date = eval { $Self->_getDateObj($Calendar, $Properties{dtstamp}, 'UTC') };
  0            
2153 0 0         $Event{updated} = $Date->iso8601() . 'Z' if $Date;
2154             }
2155 0   0       $Event{updated} ||= DateTime->now->iso8601();
2156 0 0         $Event{sequence} = int($Properties{sequence}{value}) if $Properties{sequence};
2157 0 0         $Event{method} = $method if $method;
2158              
2159             # ============= What
2160 0 0         $Event{title} = $Properties{summary}{value} if $Properties{summary};
2161 0 0         $Event{description} = join("\n", @description) if @description;
2162             # htmlDescription is not supported
2163 0 0         $Event{links} = \%Links if %Links;
2164 0           my $language;
2165 0 0 0       if ($Properties{description} and $Properties{description}{params}{language}) {
2166 0           $language = $Properties{description}{params}{language}[0];
2167             }
2168 0 0 0       if ($Properties{summary} and $Properties{summary}{params}{language}) {
2169 0           $language = $Properties{summary}{params}{language}[0];
2170             }
2171 0 0         $Event{locale} = $language if $language;
2172             # translations is not supported
2173              
2174             # ============= Where
2175             # XXX - support more structured representations from VEVENTs
2176 0 0         if ($Properties{location}{value}) {
2177 0           $Event{locations}{location} = { name => $Properties{location}{value} };
2178             }
2179 0 0 0       if (not $IsAllDay and $StartTimeZone and $StartTimeZone ne $EndTimeZone) {
      0        
2180 0           $Event{locations}{end} = { rel => 'end', timeZone => $EndTimeZone };
2181             }
2182              
2183             # ============= When
2184 0 0         $Event{isAllDay} = $IsAllDay ? $JSON::true : $JSON::false;
2185 0 0         $Event{start} = $Start->iso8601() if ref($Start);
2186 0 0         $Event{timeZone} = $StartTimeZone if not $IsAllDay;
2187 0           my $duration = $Self->_make_duration($End->subtract_datetime($Start), $IsAllDay);
2188 0 0         $Event{duration} = $duration if $duration;
2189              
2190 0 0         $Event{recurrenceRule} = \%Recurrence if %Recurrence;
2191 0 0         $Event{recurrenceOverrides} = \%Overrides if %Overrides;
2192              
2193             # ============= Scheduling
2194 0 0         if ($Properties{status}{value}) {
2195 0 0         $Event{status} = lc($Properties{status}{value}) if lc($Properties{status}{value}) ne 'confirmed';
2196             }
2197 0 0         if ($Properties{transp}{value}) {
2198 0 0         $Event{showAsFree} = $JSON::true if lc($Properties{transp}{value}) eq 'transparent';
2199             }
2200 0           foreach my $email (sort keys %Participants) { # later wins
2201 0 0         $Event{replyTo} = { imip => "mailto:$email" } if grep { $_ eq 'owner' } @{$Participants{$email}{roles}};
  0            
  0            
2202             }
2203 0 0         $Event{participants} = \%Participants if %Participants;
2204              
2205             # ============= Alerts
2206             # useDefaultAlerts is not supported
2207 0 0         $Event{alerts} = \%Alerts if %Alerts;
2208              
2209 0 0         if ($Properties{lastmodified}{value}) {
2210             # UTC item
2211 0           my $Date = eval { $Self->_getDateObj($Calendar, $Properties{lastmodified}, 'UTC') };
  0            
2212 0           $Event{lastModified} = $Date->iso8601() . 'Z';
2213             }
2214 0 0         if ($Properties{'recurrence-id'}{value}) {
2215             # in our system it's always in the timezone of the event, but iCloud
2216             # returns it in UTC despite the event having a timezone. Super weird.
2217             # Anyway, we need to format it to the StartTimeZone of the parent
2218             # event if there is one, and we don't have that yet!
2219 0           $Event{_recurrenceObj} = $Self->_getDateObj($Calendar, $Properties{'recurrence-id'});
2220             }
2221 0           push @Events, \%Event;
2222             }
2223             }
2224              
2225 0           return \@Events;
2226             }
2227              
2228             sub _getTimeZone {
2229 0     0     my $Self = shift;
2230 0           my ($Calendar, $Element) = @_;
2231              
2232 0 0         if ($Element->{value} =~ m/Z$/) {
2233 0           return 'Etc/UTC';
2234             }
2235              
2236 0           my $TZID = $Element->{params}{tzid}[0];
2237              
2238 0 0         return undef unless $TZID;
2239              
2240 0 0         return $Self->{_tznamemap}{$TZID} if exists $Self->{_tznamemap}{$TZID};
2241              
2242 0           my %TzOffsets;
2243              
2244 0 0         foreach my $VTimeZone (@{$Calendar->{objects} || []}) {
  0            
2245 0 0         next unless lc $VTimeZone->{type} eq 'vtimezone';
2246 0 0 0       next unless ($VTimeZone->{properties}{tzid}[0]{value} || '') eq $TZID;
2247              
2248 0 0         foreach my $Observance (@{$VTimeZone->{objects} || []}) {
  0            
2249 0 0 0       next unless grep { (lc $Observance->{type} || '') eq $_ } qw{standard daylight};
  0            
2250 0 0         next unless defined $Observance->{properties}{tzoffsetto}[0]{value};
2251              
2252             $TzOffsets{lc $Observance->{type}}
2253 0           = $Observance->{properties}{tzoffsetto}[0]{value};
2254             }
2255             }
2256              
2257 0 0         return undef unless exists $TzOffsets{standard};
2258              
2259             my $TimeZone = Net::CalDAVTalk::TimeZones->GetTimeZone(
2260             TZID => $TZID,
2261             Time => $Element->{value},
2262             StandardTzOffsetTo => $TzOffsets{standard},
2263             ($TzOffsets{daylight}
2264             ? (DaylightTzOffsetTo => $TzOffsets{daylight})
2265 0   0       : ()),
2266             ) || undef;
2267              
2268 0           $Self->{_tznamemap}{$TZID} = $TimeZone;
2269 0           return $TimeZone;
2270             }
2271              
2272             sub _wireDate {
2273             # format: YYYY-MM-DDTHH:MM:SS Z?
2274 0     0     my $isoDate = shift;
2275 0   0       my $timeZone = shift || $FLOATING;
2276 0 0         confess "Invalid value '$isoDate' was not ISO8601" unless $isoDate =~ m/^(\d{4,})-(\d\d)-(\d\d)T(\d\d):(\d\d):(\d\d)(Z?)$/i;
2277 0 0         $timeZone = 'Etc/UTC' if $7;
2278              
2279 0 0         my $Date = DateTime->_new(
2280             year => $1,
2281             month => $2,
2282             day => $3,
2283             hour => $4,
2284             minute => $5,
2285             second => $6,
2286             time_zone => $timeZone,
2287             locale => $LOCALE,
2288             ) or confess "Invalid value '$isoDate'";
2289              
2290 0           return $Date;
2291             }
2292              
2293             sub _vDate {
2294             # format: :YYYYMMDDTHHMMSS (floating)
2295             # format: :YYYYMMDDTHHMMSSZ (UTC)
2296             # format: ;TZID=X/Y:YYMMDDTHHMMSS (zoned)
2297             # format: ;TYPE=DATE:YYYYMMDD (but we don't know about that)
2298 0     0     my $vDate = shift;
2299              
2300 0 0         if ($vDate =~ m/^(\d\d\d\d)(\d\d)(\d\d)T(\d\d)(\d\d)(\d\d)(\.\d+)?(Z?)$/i) {
2301 0 0         my $Date = DateTime->_new(
    0          
2302             year => $1,
2303             month => $2,
2304             day => $3,
2305             hour => $4,
2306             minute => $5,
2307             second => $6,
2308             # ignore milliseconds in $7
2309             time_zone => ($8 eq 'Z' ? $UTC : $FLOATING),
2310             locale => $LOCALE,
2311             ) or confess "Invalid value '$vDate' for DATETIME";
2312              
2313 0           return ($Date, 1);
2314             }
2315              
2316 0 0         if ($vDate =~ m/^(\d\d\d\d)(\d\d)(\d\d)$/) {
2317             # all day
2318 0 0         my $Date = DateTime->_new(
2319             year => $1,
2320             month => $2,
2321             day => $3,
2322             time_zone => $FLOATING,
2323             locale => $LOCALE,
2324             ) or confess "Invalid value '$vDate' for DATE";
2325              
2326 0           return ($Date, 0);
2327             }
2328              
2329             # we only support those two patterns
2330 0           confess "Date '$vDate' was neither a DATE or DATETIME value";
2331             }
2332              
2333             sub _makeVTime {
2334 0     0     my $Self = shift;
2335 0           my ($TimeZones, $wire, $tz, $IsAllDay) = @_;
2336              
2337 0           my $date = _wireDate($wire, $tz);
2338              
2339 0           return $Self->_makeVTimeObj($TimeZones, $date, $tz, $IsAllDay);
2340             }
2341              
2342             sub _makeVTimeObj {
2343 0     0     my $Self = shift;
2344 0           my ($TimeZones, $date, $tz, $IsAllDay) = @_;
2345              
2346             # all day?
2347 0 0         if ($IsAllDay) {
2348 0           return [$date->strftime('%Y%m%d'), { VALUE => 'DATE' }];
2349             }
2350              
2351             # floating?
2352 0 0         unless ($tz) {
2353 0           return [$date->strftime('%Y%m%dT%H%M%S')];
2354             }
2355              
2356             # UTC?
2357 0 0         if ($UTCLinks{$tz}) {
2358 0           return [$date->strftime('%Y%m%dT%H%M%SZ')];
2359             }
2360              
2361 0           my $zone = $Self->tz($tz);
2362              
2363 0           $TimeZones->{$zone->name()} = 1;
2364              
2365 0           return [$date->strftime('%Y%m%dT%H%M%S'), { TZID => $zone->name() }];
2366             }
2367              
2368             sub _makeZTime {
2369 0     0     my ($Self, $date) = @_;
2370 0           return $Self->_makeVTime({}, $date, 'UTC');
2371             }
2372              
2373             sub _makeLTime {
2374 0     0     my $Self = shift;
2375 0           my ($TimeZones, $ltime, $tz, $IsAllDay) = @_;
2376              
2377 0           my $date = _wireDate($ltime, $Self->tz($tz));
2378              
2379 0 0         return [$date->strftime('%Y%m%d'), { VALUE => 'DATE' }] if $IsAllDay;
2380              
2381 0 0         unless ($tz) {
2382             # floating
2383 0           return [$date->strftime('%Y%m%dT%H%M%S')];
2384             }
2385              
2386 0 0         if ($tz =~ m/UTC/i) {
2387 0           return [$date->strftime('%Y%m%dT%H%M%SZ')];
2388             }
2389              
2390             # XXX - factor this crap out
2391 0           $TimeZones->{$tz} = 1;
2392              
2393             # XXX - use our cache
2394 0           my $zone = $Self->tz($tz);
2395              
2396 0           return [$date->strftime('%Y%m%dT%H%M%S'), { TZID => $zone->name() }];
2397             }
2398              
2399             sub _argsToVEvents {
2400 0     0     my $Self = shift;
2401 0           my ($TimeZones, $Args, $recurrenceData) = @_;
2402 0           my @VEvents;
2403              
2404 0           my $VEvent = Data::ICal::Entry::Event->new();
2405              
2406             # required properties
2407             $VEvent->add_properties(
2408             uid => $Args->{uid},
2409             sequence => ($Args->{sequence} || 0),
2410 0 0 0       transp => ($Args->{showAsFree} ? 'TRANSPARENT' : 'OPAQUE'),
2411             );
2412              
2413 0 0         if ($recurrenceData) {
2414 0           my ($recurrenceId, $TopLevel) = @$recurrenceData;
2415 0           $VEvent->add_property('recurrence-id' => $Self->_makeLTime($TimeZones, $recurrenceId, $TopLevel->{timeZone}, $TopLevel->{isAllDay}));
2416             }
2417              
2418             # direct copy if properties exist
2419 0           foreach my $Property (qw{description title}) {
2420 0   0       my $Prop = $Args->{$Property} // '';
2421 0 0         next if $Prop eq '';
2422 0           my %lang;
2423 0 0         $lang{language} = $Args->{locale} if exists $Args->{locale};
2424 0           my $key = $Property;
2425 0 0         $key = 'summary' if $Property eq 'title';
2426 0           $VEvent->add_property($key => [$Prop, \%lang]);
2427             }
2428              
2429             # dates in UTC - stored in UTC
2430 0 0         $VEvent->add_property(created => $Self->_makeZTime($Args->{created})) if $Args->{created};
2431 0   0       $VEvent->add_property(dtstamp => $Self->_makeZTime($Args->{updated} || DateTime->now->iso8601()));
2432              
2433             # dates in localtime - zones based on location
2434 0           my $EndTimeZone;
2435 0   0       my $locations = $Args->{locations} || {};
2436 0           foreach my $id (sort keys %$locations) {
2437 0 0 0       if ($locations->{$id}{rel} and $locations->{id}{rel} eq 'end') {
2438 0           $EndTimeZone = $locations->{end}{timeZone};
2439             }
2440 0 0         if ($locations->{$id}{name}) {
2441 0           $VEvent->add_property(location => $locations->{$id}{name});
2442             }
2443             }
2444              
2445 0           my $StartTimeZone = $Args->{timeZone};
2446 0           my $Start = _wireDate($Args->{start}, $StartTimeZone);
2447 0           $VEvent->add_property(dtstart => $Self->_makeVTimeObj($TimeZones, $Start, $StartTimeZone, $Args->{isAllDay}));
2448 0 0         if ($Args->{duration}) {
2449 0   0       $EndTimeZone //= $StartTimeZone;
2450 0           my $Duration = eval { DateTime::Format::ICal->parse_duration($Args->{duration}) };
  0            
2451 0 0         my $End = $Start->clone()->add($Duration) if $Duration;
2452 0           $VEvent->add_property(dtend => $Self->_makeVTimeObj($TimeZones, $End, $EndTimeZone, $Args->{isAllDay}));
2453             }
2454              
2455 0 0         if ($Args->{recurrenceRule}) {
2456 0           my %Recurrence = $Self->_makeRecurrence($Args->{recurrenceRule}, $Args->{isAllDay}, $StartTimeZone);
2457              
2458             # RFC 2445 4.3.10 - FREQ is the first part of the RECUR value type.
2459             # RFC 5545 3.3.10 - FREQ should be first to ensure backward compatibility.
2460             my $rule = join(';',
2461             ('FREQ=' . delete($Recurrence{FREQ})),
2462 0           (map { "$_=$Recurrence{$_}" } keys %Recurrence),
  0            
2463             );
2464 0           $VEvent->add_property(rrule => $rule);
2465             }
2466              
2467 0 0         if ($Args->{recurrenceOverrides}) {
2468 0           foreach my $recurrenceId (sort keys %{$Args->{recurrenceOverrides}}) {
  0            
2469 0           my $val = $Args->{recurrenceOverrides}{$recurrenceId};
2470 0 0         if ($val) {
2471 0 0         if (keys %$val) {
2472 0           my $SubEvent = $Self->_maximise($Args, $val, $recurrenceId);
2473 0           push @VEvents, $Self->_argsToVEvents($TimeZones, $SubEvent, [$recurrenceId, $Args]);
2474             }
2475             else {
2476 0           $VEvent->add_property(rdate => $Self->_makeLTime($TimeZones, $recurrenceId, $StartTimeZone, $Args->{isAllDay}));
2477             }
2478             }
2479             else {
2480 0           $VEvent->add_property(exdate => $Self->_makeLTime($TimeZones, $recurrenceId, $StartTimeZone, $Args->{isAllDay}));
2481             }
2482             }
2483             }
2484              
2485 0 0         if ($Args->{alerts}) {
2486 0           for my $id (sort keys %{$Args->{alerts}}) {
  0            
2487 0           my $Alert = $Args->{alerts}{$id};
2488              
2489 0   0       my $Type = $Alert->{action}{type} // '';
2490 0   0       my $Recipients = $Alert->{action}{recipients} // [];
2491 0   0       my $Uri = $Alert->{action}{uri} // '';
2492 0           my $Offset = $Alert->{offset};
2493 0 0         my $Sign = $Alert->{relativeTo} =~ m/before/ ? '-' : '';
2494 0 0         my $Loc1 = $Alert->{relativeTo} =~ m/end/ ? "ends" : "starts";
2495 0 0         my $Loc2 = $Alert->{relativeTo} =~ m/end/ ? "ended" : "started";
2496 0           my $Minutes = DateTime::Format::ICal->parse_duration(uc $Offset)->in_units('minutes');
2497              
2498 0           my $VAlarm;
2499              
2500 0 0 0       if ($Type eq 'display') {
    0          
2501 0           $VAlarm = Data::ICal::Entry::Alarm::Display->new();
2502 0 0         $VAlarm->add_properties(
2503             description => (($Sign eq '-')
2504             ? "'$Args->{title}' $Loc1 in $Minutes minutes"
2505             : "'$Args->{title}' $Loc2 $Minutes minutes ago"),
2506             );
2507             }
2508             elsif ($Type eq 'email' || $Type eq 'uri') {
2509 0           my ($Summary, $Description);
2510              
2511 0 0         if ($Sign eq '-') {
2512 0           $Summary = "Event alert: '$Args->{title}' $Loc1 in $Minutes minutes";
2513 0           $Description = "Your event '$Args->{title}' $Loc1 in $Minutes minutes";
2514             }
2515             else {
2516 0           $Summary = "Event alert: '$Args->{title}' $Loc2 $Minutes minutes ago";
2517 0           $Description = "Your event '$Args->{title}' $Loc2 $Minutes minutes ago";
2518             }
2519              
2520 0           $VAlarm = Data::ICal::Entry::Alarm::Email->new();
2521             $VAlarm->add_properties(
2522             summary => $Summary,
2523             description => join("\n",
2524             $Description,
2525             "",
2526             "Description:",
2527             $Args->{description},
2528             # XXX more
2529             ),
2530 0           (map { ( attendee => "MAILTO:$_" ) } @$Recipients), # XXX naive?
  0            
2531             );
2532              
2533 0 0         if ($Type eq 'uri') {
2534 0           $VAlarm->add_property("X-URI", $Uri);
2535             }
2536             }
2537             else {
2538 0           confess "Unknown alarm type $Type";
2539             }
2540              
2541 0           $VAlarm->add_property(uid => $id);
2542 0           $VAlarm->add_property(trigger => "${Sign}$Offset");
2543 0 0         $VAlarm->add_property(related => 'end') if $Alert->{relativeTo} =~ m/end/;
2544              
2545 0 0         if ($Alert->{action}{acknowledged}) {
2546 0           $VAlarm->add_property(acknowledged => $Self->_makeZTime($Alert->{action}{acknowledged}));
2547             }
2548              
2549 0           $VEvent->add_entry($VAlarm);
2550             }
2551             }
2552              
2553 0           my %namemap;
2554 0 0         if ($Args->{participants}) {
2555 0           foreach my $Address (sort keys %{$Args->{participants}}) {
  0            
2556 0           my $Attendee = $Args->{participants}{$Address};
2557 0   0       my $Email = $Attendee->{email} || $Address;
2558 0           my $Rsvp = $Attendee->{rsvp};
2559              
2560 0           my %AttendeeProps;
2561 0 0         if ($Attendee->{"name"}) {
2562 0           $AttendeeProps{"CN"} = $Attendee->{"name"};
2563 0           $namemap{lc "mailto:$Email"}= $Attendee->{"name"};
2564             }
2565              
2566 0 0         next unless grep { $_ eq 'attendee' } @{$Attendee->{roles}};
  0            
  0            
2567              
2568 0 0         $AttendeeProps{"CUTYPE"} = uc $Attendee->{"kind"} if defined $Attendee->{"kind"};
2569 0 0         $AttendeeProps{"RSVP"} = uc $Attendee->{"scheduleRSVP"} if defined $Attendee->{"scheduleRSVP"};
2570 0 0         $AttendeeProps{"X-SEQUENCE"} = $Attendee->{"x-sequence"} if defined $Attendee->{"x-sequence"};
2571 0 0         $AttendeeProps{"X-DTSTAMP"} = $Self->_makeZTime($Attendee->{"scheduleUpdated"}) if defined $Attendee->{"scheduleUpdated"};
2572 0           foreach my $prop (keys %AttendeeProps) {
2573 0 0         delete $AttendeeProps{$prop} if $AttendeeProps{$prop} eq '';
2574             }
2575 0 0 0       if (grep { $_ eq 'chair' } @{$Attendee->{roles}}) {
  0 0 0        
  0 0          
2576 0           $Attendee->{ROLE} = 'CHAIR';
2577             }
2578             elsif ($Attendee->{schedulePriority} and $Attendee->{schedulePriority} eq 'optional') {
2579 0           $Attendee->{ROLE} = 'OPT-PARTICIPANT';
2580             }
2581             elsif ($Attendee->{schedulePriority} and $Attendee->{schedulePriority} eq 'non-participant') {
2582 0           $Attendee->{ROLE} = 'NON-PARTICIPANT';
2583             }
2584             # default is REQ-PARTICIPANT
2585              
2586 0 0         $AttendeeProps{PARTSTAT} = uc $Attendee->{"scheduleStatus"} if $Attendee->{"scheduleStatus"};
2587              
2588 0           $VEvent->add_property(attendee => [ "MAILTO:$Email", \%AttendeeProps ]);
2589             }
2590             }
2591 0 0         if ($Args->{replyTo}) {
2592 0 0         if ($Args->{replyTo}{imip}) {
2593 0           my $CN = $namemap{lc $Args->{replyTo}{imip}};
2594 0 0         $VEvent->add_property(organizer => [ $Args->{replyTo}{imip}, $CN ? {CN => $CN} : () ]);
2595             }
2596             }
2597              
2598 0 0         if ($Args->{links}) {
2599 0           foreach my $uri (sort keys %{$Args->{links}}) {
  0            
2600 0           my $Attach = $Args->{links}{$uri};
2601 0   0       my $Url = $Attach->{href} || $uri;
2602 0 0 0       if ($Attach->{rel} && $Attach->{rel} eq 'enclosure') {
2603 0           my $FileName = $Attach->{title};
2604 0           my $Mime = $Attach->{type};
2605 0           my $Size = $Attach->{size};
2606              
2607 0           my %AttachProps;
2608 0 0         $AttachProps{FMTTYPE} = $Mime if defined $Mime;
2609 0 0         $AttachProps{SIZE} = $Size if defined $Size;
2610 0 0         $AttachProps{FILENAME} = $FileName if defined $FileName;
2611 0           $VEvent->add_property(attach => [ $Url, \%AttachProps ]);
2612             }
2613             # otherwise it's just a URL
2614             else {
2615 0           $VEvent->add_property(url => [ $Url ]);
2616             }
2617             }
2618             }
2619              
2620             # detect if this is a dummy top-level event and skip it
2621 0 0 0       unshift @VEvents, $VEvent unless ($Args->{replyTo} and not $Args->{participants});
2622              
2623 0           return @VEvents;
2624             }
2625              
2626             sub _argsToVCalendar {
2627 0     0     my $Self = shift;
2628 0           my $Item = shift;
2629 0           my %ExtraProp = @_;
2630              
2631 0           my $VCalendar = Data::ICal->new();
2632 0           my $havepid = 0;
2633              
2634 0           foreach my $extra (keys %ExtraProp) {
2635 0           $VCalendar->add_properties($extra => $ExtraProp{$extra});
2636             }
2637 0           $VCalendar->add_properties(calscale => 'GREGORIAN');
2638              
2639 0           my @VEvents;
2640             my %TimeZones;
2641 0 0         foreach my $Args (ref $Item eq 'ARRAY' ? @$Item : $Item) {
2642 0 0 0       if (not $havepid and $Args->{prodId}) {
2643 0           $VCalendar->add_properties('prodid' => $Args->{prodId});
2644 0           $havepid = 1;
2645             }
2646             # initialise timestamp if not given one
2647 0   0       $Args->{dtstamp} //= DateTime->now()->strftime('%Y-%m-%dT%H:%M:%S');
2648 0           push @VEvents, $Self->_argsToVEvents(\%TimeZones, $Args);
2649             }
2650              
2651             # add timezone parts first
2652 0           foreach my $Zone (sort keys %TimeZones) {
2653 0           my $VTimeZone = Net::CalDAVTalk::TimeZones->GetVTimeZone($Zone);
2654 0 0         next unless $VTimeZone;
2655 0           $VCalendar->add_entry($VTimeZone);
2656             }
2657              
2658             # then the events
2659 0           foreach my $VEvent (@VEvents) {
2660 0           $VCalendar->add_entry($VEvent);
2661             }
2662              
2663 0           return $VCalendar;
2664             }
2665              
2666             sub _makeRecurrence {
2667 0     0     my $Self = shift;
2668 0           my ($Args, $IsAllDay, $TZ) = @_;
2669              
2670 0           my %Recurrence;
2671              
2672             # validate simple recurrence properties {{{
2673              
2674 0 0         unless (ref($Args) eq 'HASH') {
2675 0           confess 'Invalid recurrence';
2676             }
2677              
2678 0 0         if ($Args->{frequency}) {
2679 0 0         unless (grep { $_ eq $Args->{frequency} } @Frequencies) {
  0            
2680 0           confess "Invalid recurrence frequency ($Args->{frequency})";
2681             }
2682              
2683 0           $Recurrence{FREQ} = uc($Args->{frequency});
2684             }
2685             else {
2686 0           confess 'Recurrence frequency not specified';
2687             }
2688              
2689 0 0         if (defined $Args->{interval}) {
2690 0 0         unless ($Args->{interval} =~ /^\d+$/) {
2691 0           confess "Invalid recurrence interval ($Args->{interval})";
2692             }
2693              
2694 0 0         if ($Args->{interval} == 0) {
2695 0           confess "Recurrence interval is out of range ($Args->{interval})";
2696             }
2697              
2698 0 0         if ($Args->{interval} > 1) {
2699 0           $Recurrence{INTERVAL} = $Args->{interval};
2700             }
2701             }
2702              
2703 0 0         if (defined $Args->{firstDayOfWeek}) {
2704 0 0         unless (exists $DaysByIndex{$Args->{firstDayOfWeek}}) {
2705 0           confess "Invalid recurrence firstDayOfWeek ($Args->{firstDayOfWeek})";
2706             }
2707              
2708 0 0         unless ($Args->{firstDayOfWeek} == 1){
2709 0           $Recurrence{WKST} = uc $DaysByIndex{$Args->{firstDayOfWeek}};
2710             }
2711             }
2712              
2713 0 0         if ($Args->{byDay}) {
2714 0 0         unless (ref($Args->{byDay}) eq 'ARRAY') {
2715 0           confess 'Invalid recurrence byDay';
2716             }
2717              
2718 0 0         unless (@{$Args->{byDay}}) {
  0            
2719 0           confess 'Recurrence byDay is empty';
2720             }
2721              
2722 0           $Recurrence{BYDAY} = join(',', map{ _byDay2BYDAY($_) } @{$Args->{byDay}});
  0            
  0            
2723             }
2724              
2725 0 0         if ($Args->{byMonth}) {
2726 0 0         unless (ref($Args->{byMonth}) eq 'ARRAY') {
2727 0           confess 'Invalid recurrence byMonth';
2728             }
2729              
2730 0 0         unless (@{$Args->{byMonth}}) {
  0            
2731 0           confess 'Recurrence byMonth is empty';
2732             }
2733              
2734 0           my @BYMONTHS;
2735              
2736 0           foreach my $byMonth (@{$Args->{byMonth}}) {
  0            
2737 0 0         unless ($byMonth =~ /^(\d+)L?$/i) {
2738 0           confess "Recurrence byMonth is not a number with optional L ($byMonth)";
2739             }
2740 0           my $monthNum = $1;
2741 0 0 0       unless ($monthNum >= 1 and $monthNum <= 13) {
2742             # not sure if 13 is OK
2743 0           confess "Recurrence byMonth is too high ($monthNum)";
2744             }
2745              
2746 0           push @BYMONTHS, $byMonth;
2747             }
2748              
2749 0           $Recurrence{BYMONTH} = join ',', @BYMONTHS;
2750             }
2751              
2752 0 0         if (defined $Args->{count}) {
2753 0 0         if (defined $Args->{until}) {
2754 0           confess 'Recurrence count and until cannot both be set';
2755             }
2756              
2757 0 0         unless ($Args->{count} =~ /^\d+$/) {
2758 0           confess "Invalid recurrence count ($Args->{count})";
2759             }
2760              
2761 0           $Recurrence{COUNT} = $Args->{count};
2762             }
2763              
2764 0 0         if ($Args->{until}) {
2765 0           my $Until = _wireDate($Args->{until}, $Self->tz($TZ));
2766              
2767 0 0         if ($IsAllDay) {
2768 0           $Recurrence{UNTIL} = $Until->strftime('%Y%m%d');
2769             }
2770             else {
2771             # API is in Localtime, but both iCloud and Google use 'Z' times as per
2772             # rfc2445, so we'll copy them for compatibility.
2773 0           $Until->set_time_zone($UTC);
2774 0           $Recurrence{UNTIL} = $Until->strftime('%Y%m%dT%H%M%SZ');
2775             }
2776             }
2777              
2778             # }}}
2779              
2780             # validate generic recurrence properties {{{
2781              
2782 0           foreach my $Property (keys %RecurrenceProperties) {
2783 0           my $Name = $RecurrenceProperties{$Property}{name};
2784              
2785 0 0         if ($Args->{$Name}) {
2786 0 0         unless (ref($Args->{$Name}) eq 'ARRAY') {
2787 0           confess "Invalid recurrence $Name";
2788             }
2789              
2790 0 0         unless (@{$Args->{$Name}}) {
  0            
2791 0           confess "Recurrence $Name is empty";
2792             }
2793              
2794 0           my @Values;
2795              
2796 0           foreach my $Value (@{$Args->{$Name}}) {
  0            
2797             my ($Valid, $Min) = $RecurrenceProperties{$Property}{signed}
2798 0 0         ? ('[-+]?[1-9]\d*', ($RecurrenceProperties{$Property}{max} * -1))
2799             : ('\d+', 0);
2800              
2801 0 0         unless ($Value =~ /^$Valid$/) {
2802 0           confess "Invalid recurrence $Name ($Value)";
2803             }
2804              
2805 0 0 0       unless (($Min <= $Value) and ($Value <= $RecurrenceProperties{$Property}{max})) {
2806 0           confess "Recurrence $Name is out of range ($Value)";
2807             }
2808              
2809 0           push @Values, $Value;
2810             }
2811              
2812 0           $Recurrence{uc $Property} = join ',', @Values;
2813             }
2814             }
2815              
2816             # }}}
2817              
2818 0           return %Recurrence;
2819             }
2820              
2821             =head2 $self->vcalendarToEvents($Data)
2822              
2823             Convert a text vcalendar (either a single event or an entire ical file) into an array of events.
2824              
2825             Returns an array (not arrayref) of Events in UID order.
2826              
2827             e.g.
2828              
2829             foreach my $Event ($CalDAV->vcalendarToEvents($Data)) {
2830             # ...
2831             }
2832              
2833             =cut
2834              
2835             sub _insert_override {
2836 0     0     my $Event = shift;
2837 0           my $recurrenceId = shift;
2838 0           my $Recurrence = shift;
2839              
2840 0           my %override;
2841 0           my %oldkeys = map { $_ => 1 } keys %$Event;
  0            
2842 0           foreach my $Key (sort keys %$Recurrence) {
2843 0           delete $oldkeys{$Key};
2844 0 0         next if $MustBeTopLevel{$Key}; # XXX - check safeeq and die?
2845 0 0         if ($Key eq 'start') {
2846             # special case, it's the recurrence-id
2847 0 0         next if _safeeq($Recurrence->{start}, $recurrenceId);
2848 0           $override{start} = $Recurrence->{start};
2849 0           next;
2850             }
2851 0 0         next if _safeeq($Recurrence->{$Key}, $Event->{$Key});
2852 0           _add_override(\%override, _quotekey($Key), $Recurrence->{$Key}, $Event->{$Key});
2853             }
2854              
2855 0           foreach my $Key (sort keys %oldkeys) {
2856 0 0         next if $MustBeTopLevel{$Key};
2857 0           $override{$Key} = $JSON::null;
2858             }
2859              
2860             # in theory should never happen, but you could edit something back to be identical
2861 0 0         return unless %override;
2862 0           $Event->{recurrenceOverrides}{$recurrenceId} = \%override;
2863             }
2864              
2865             sub vcalendarToEvents {
2866 0     0 1   my $Self = shift;
2867 0           my $Data = shift;
2868              
2869             # Internal caches need to be invalidated on each item read! A bit evil really...
2870 0           delete $Self->{_tznamemap};
2871              
2872 0           my %map;
2873             my %exceptions;
2874 0           my $Events = $Self->_getEventsFromVCalendar($Data);
2875              
2876 0           foreach my $Event (@$Events) {
2877 0           my $uid = $Event->{uid};
2878 0 0         if ($Event->{_recurrenceObj}) {
    0          
2879 0           push @{$exceptions{$uid}}, $Event;
  0            
2880             }
2881             elsif ($map{$uid}) {
2882             # it looks like sometimes Google doesn't remember to put the Recurrence ID
2883             # on additional recurrences after the first one, which is going to screw up
2884             # pretty badly because if the date has changed, then we can't even notice
2885             # which recurrent it was SUPPOSED to be. *sigh*.
2886 0           warn "DUPLICATE EVENT FOR $uid\n" . Dumper($map{$uid}, $Event);
2887 0           push @{$exceptions{$uid}}, $Event;
  0            
2888 0           $map{$uid}{_dirty} = 1;
2889             }
2890             else {
2891 0           $map{$uid} = $Event;
2892             }
2893             }
2894              
2895 0           foreach my $uid (keys %exceptions) {
2896 0 0         unless ($map{$uid}) {
2897             # create a synthetic top-level
2898 0           my $First = $exceptions{$uid}[0];
2899             $map{$uid} = {
2900             uid => $uid,
2901             # these two are required at top level, but may be different
2902             # in recurrences so aren't in MustBeTopLevel
2903             start => $First->{start},
2904             updated => $First->{updated},
2905 0           };
2906 0 0         $map{$uid}{timeZone} = $First->{timeZone} unless $First->{isAllDay};
2907 0           foreach my $key (keys %MustBeTopLevel) {
2908 0 0         $map{$uid}{$key} = $First->{$key} if exists $First->{$key};
2909             }
2910             }
2911 0           foreach my $SubEvent (@{$exceptions{$uid}}) {
  0            
2912 0           my $recurrenceId = $SubEvent->{start};
2913 0 0         if ($SubEvent->{_recurrenceObj}) {
2914 0           my $Date = delete $SubEvent->{_recurrenceObj};
2915 0 0         $Date->set_time_zone($map{$uid}{timeZone}) if $map{$uid}{timeZone};
2916 0           $recurrenceId = $Date->iso8601();
2917             }
2918 0           _insert_override($map{$uid}, $recurrenceId, $SubEvent);
2919             }
2920             }
2921              
2922 0           return map { $map{$_} } sort keys %map;
  0            
2923             }
2924              
2925             =head2 $self->UpdateAddressSet($DisplayName, $EmailAddress)
2926              
2927             Set the address set and display name for the calendar user (if supported)
2928              
2929             =cut
2930              
2931             sub UpdateAddressSet {
2932 0     0 1   my ($Self, $NewDisplayName, $NewAddressSet) = @_;
2933              
2934 0           my ($DisplayName, $AddressSet) = $Self->GetProps(\$Self->{principal}, 'D:displayname', [ 'C:calendar-user-address-set', 'D:href' ]);
2935              
2936 0 0 0       if (!$AddressSet || $AddressSet ne "mailto:" . $NewAddressSet ||
      0        
      0        
2937             !$DisplayName || $DisplayName ne $NewDisplayName) {
2938 0           $Self->Request(
2939             'PROPPATCH',
2940             "",
2941             x('D:propertyupdate', $Self->NS(),
2942             x('D:set',
2943             x('D:prop',
2944             x('D:displayname', $NewDisplayName),
2945             x('C:calendar-user-address-set', "mailto:" . $NewAddressSet),
2946             )
2947             )
2948             )
2949             );
2950 0           return 1;
2951             }
2952              
2953 0           return 0;
2954             }
2955              
2956             =head2 $self->GetICal($calendarId, $isFreeBusy)
2957              
2958             Given a calender, fetch all the events and generate an ical format file
2959             suitable for import into a client.
2960              
2961             =cut
2962              
2963             sub GetICal {
2964 0     0 1   my $Self = shift;
2965 0           my $calendarId = shift;
2966 0           my $isFreeBusy = shift;
2967              
2968 0 0         confess "Need a calendarId" unless $calendarId;
2969              
2970 0           my $Calendars = $Self->GetCalendars();
2971 0           foreach my $Cal (@$Calendars) {
2972 0 0         next unless $calendarId eq $Cal->{id};
2973 0 0         my ($Events, $Errors) = $isFreeBusy ?
2974             $Self->GetFreeBusy($calendarId) :
2975             $Self->GetEvents($calendarId);
2976 0 0         return undef if @$Errors;
2977 0           $Self->_stripNonICal($_) for @$Events;
2978             my $VCalendar = $Self->_argsToVCalendar($Events,
2979             method => 'PUBLISH',
2980             'x-wr-calname' => $Cal->{name},
2981             'x-wr-timezone' => $Cal->{timeZone},
2982             'x-apple-calendar-color' => $Cal->{color},
2983             # XXX - do we want to add our sync-token here or something?
2984 0           );
2985 0           return ($VCalendar->as_string(), $Cal);
2986             }
2987 0           return undef; # 404
2988             }
2989              
2990             sub _quotekey {
2991 0     0     my $key = shift;
2992 0           $key =~ s/\~/~0/gs;
2993 0           $key =~ s/\//~1/gs;
2994 0           return $key;
2995             }
2996              
2997             sub _unquotekey {
2998 0     0     my $key = shift;
2999 0           $key =~ s/\~1/\//gs;
3000 0           $key =~ s/\~0/~/gs;
3001 0           return $key;
3002             }
3003              
3004             sub _add_override {
3005 0     0     my ($override, $prefix, $New, $Old) = @_;
3006              
3007             # basic case - it's not an object, so we just override
3008 0 0 0       if ($ENV{JMAP_ALWAYS_FULL} or ref($New) ne 'HASH' or ref($Old) or 'HASH') {
      0        
      0        
3009 0           $override->{$prefix} = $New;
3010 0           return;
3011             }
3012              
3013             # XXX - if too many, we could just abort...
3014 0           my %subover;
3015 0           my %oldkeys = map { $_ => 1 } keys %$Old;
  0            
3016 0           foreach my $Key (sort keys %$New) {
3017 0           delete $oldkeys{$Key};
3018 0 0         next if _safeeq($New->{$Key}, $Old->{$Key});
3019 0           _add_override(\%subover, "$prefix/" . _quotekey($Key), $New->{$Key}, $Old->{$Key});
3020             }
3021 0           foreach my $Key (sort keys %oldkeys) {
3022 0           $subover{"$prefix/" . _quotekey($Key)} = $JSON::null;
3023             }
3024              
3025             # which one is better?
3026 0 0         if (length(encode_json($New)) < length(encode_json(\%subover))) {
3027 0           $override->{$prefix} = $New; # cheaper to just encode the whole object
3028             }
3029             else {
3030 0           $override->{$_} = $subover{$_} for keys %subover;
3031             }
3032             }
3033              
3034             sub _apply_patch {
3035 0     0     my $path = shift;
3036 0           my $hash = shift;
3037 0           my $value = shift;
3038              
3039 0 0         return unless $path =~ s{^([^/]+)(/?)}{};
3040 0 0         return unless ref($hash) eq 'HASH';
3041 0           my $qkey = $1;
3042 0           my $slash = $2;
3043 0           my $key = _unquotekey($qkey);
3044 0 0         if ($slash) {
    0          
3045 0           _apply_patch($path, $hash->{$key}, $value);
3046             }
3047             elsif(defined $value) {
3048 0           $hash->{$key} = $value;
3049             }
3050             else {
3051 0           delete $hash->{$key};
3052             }
3053             }
3054              
3055             sub _maximise {
3056 0     0     my $Self = shift;
3057 0           my $Event = shift;
3058 0           my $Recurrence = shift;
3059 0           my $recurrenceId = shift;
3060              
3061             #warn "MAXIMIZING EVENT INTO RECURRENCE: " . Dumper($Event, $Recurrence);
3062              
3063 0           my $new = _deepcopy($Event);
3064 0           $new->{start} = $recurrenceId;
3065 0           delete $new->{recurrenceRule};
3066 0           delete $new->{recurrenceOverrides};
3067              
3068 0           foreach my $path (sort keys %$Recurrence) {
3069 0           my $value = $Recurrence->{$path};
3070 0           _apply_patch($path, $new, $value);
3071             }
3072              
3073 0           return $new;
3074             }
3075              
3076             sub _stripNonICal {
3077 0     0     my $Self = shift;
3078 0           my $Event = shift;
3079              
3080 0           delete $Event->{alerts};
3081 0           delete $Event->{attendees};
3082 0           delete $Event->{organizer};
3083              
3084 0           foreach my $exception (values %{$Event->{exceptions}}) {
  0            
3085 0 0         next unless $exception;
3086 0           $Self->_stripNonICal($exception);
3087             }
3088             }
3089              
3090             sub _safeeq {
3091 0     0     my ($a, $b) = @_;
3092 0           my $json = JSON::XS->new->canonical;
3093 0           return $json->encode([$a]) eq $json->encode([$b]);
3094             }
3095              
3096             sub _deepcopy {
3097 0     0     my $data = shift;
3098 0           my $json = JSON::XS->new->canonical;
3099 0           my $enc = $json->encode([$data]);
3100 0           my $copy = $json->decode($enc);
3101 0           return $copy->[0];
3102             }
3103              
3104              
3105             =head1 AUTHOR
3106              
3107             Bron Gondwana, C<< <brong at cpan.org> >>
3108              
3109             =head1 BUGS
3110              
3111             Please report any bugs or feature requests to C<bug-net-caldavtalk at rt.cpan.org>, or through
3112             the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-CalDAVTalk>. I will be notified, and then you'll
3113             automatically be notified of progress on your bug as I make changes.
3114              
3115              
3116              
3117              
3118             =head1 SUPPORT
3119              
3120             You can find documentation for this module with the perldoc command.
3121              
3122             perldoc Net::CalDAVTalk
3123              
3124              
3125             You can also look for information at:
3126              
3127             =over 4
3128              
3129             =item * RT: CPAN's request tracker (report bugs here)
3130              
3131             L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-CalDAVTalk>
3132              
3133             =item * AnnoCPAN: Annotated CPAN documentation
3134              
3135             L<http://annocpan.org/dist/Net-CalDAVTalk>
3136              
3137             =item * CPAN Ratings
3138              
3139             L<http://cpanratings.perl.org/d/Net-CalDAVTalk>
3140              
3141             =item * Search CPAN
3142              
3143             L<http://search.cpan.org/dist/Net-CalDAVTalk/>
3144              
3145             =back
3146              
3147              
3148             =head1 ACKNOWLEDGEMENTS
3149              
3150              
3151             =head1 LICENSE AND COPYRIGHT
3152              
3153             Copyright 2015 FastMail Pty Ltd.
3154              
3155             This program is free software; you can redistribute it and/or modify it
3156             under the terms of the the Artistic License (2.0). You may obtain a
3157             copy of the full license at:
3158              
3159             L<http://www.perlfoundation.org/artistic_license_2_0>
3160              
3161             Any use, modification, and distribution of the Standard or Modified
3162             Versions is governed by this Artistic License. By using, modifying or
3163             distributing the Package, you accept this license. Do not use, modify,
3164             or distribute the Package, if you do not accept this license.
3165              
3166             If your Modified Version has been derived from a Modified Version made
3167             by someone other than you, you are nevertheless required to ensure that
3168             your Modified Version complies with the requirements of this license.
3169              
3170             This license does not grant you the right to use any trademark, service
3171             mark, tradename, or logo of the Copyright Holder.
3172              
3173             This license includes the non-exclusive, worldwide, free-of-charge
3174             patent license to make, have made, use, offer to sell, sell, import and
3175             otherwise transfer the Package with respect to any patent claims
3176             licensable by the Copyright Holder that are necessarily infringed by the
3177             Package. If you institute patent litigation (including a cross-claim or
3178             counterclaim) against any party alleging that the Package constitutes
3179             direct or contributory patent infringement, then this Artistic License
3180             to you shall terminate on the date that such litigation is filed.
3181              
3182             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
3183             AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
3184             THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
3185             PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
3186             YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
3187             CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
3188             CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
3189             EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
3190              
3191              
3192             =cut
3193              
3194             1; # End of Net::CalDAVTalk