File Coverage

blib/lib/Data/ICal/Entry.pm
Criterion Covered Total %
statement 151 173 87.2
branch 27 36 75.0
condition 11 18 61.1
subroutine 25 31 80.6
pod 20 20 100.0
total 234 278 84.1


line stmt bran cond sub pod time code
1 13     13   102 use warnings;
  13         26  
  13         441  
2 13     13   70 use strict;
  13         23  
  13         380  
3              
4             package Data::ICal::Entry;
5 13     13   63 use base qw/Class::Accessor/;
  13         23  
  13         7280  
6 13     13   30103 use Data::ICal::Property;
  13         35  
  13         65  
7 13     13   6582 use Sys::Hostname qw(); # For unique UIDs for entries
  13         12770  
  13         356  
8 13     13   85 use Carp;
  13         30  
  13         769  
9              
10 13     13   92 use constant CRLF => "\x0d\x0a";
  13         23  
  13         28262  
11              
12             =head1 NAME
13              
14             Data::ICal::Entry - Represents an entry in an iCalendar file
15              
16             =head1 SYNOPSIS
17              
18             my $vtodo = Data::ICal::Entry::Todo->new();
19             $vtodo->add_property(
20             # ... see Data::ICal::Entry::Todo documentation
21             );
22             $vtodo->add_properties( ... );
23              
24             $calendar->add_entry($vtodo);
25              
26             $event->add_entry($alarm);
27             $event->add_entries($alarm1, ...);
28              
29             # or all in one go
30             my $vtodo = Data::ICal::Entry::Todo->new( \%props, \@entries );
31              
32             =head1 DESCRIPTION
33              
34             A L object represents a single entry in an
35             iCalendar file. (Note that the iCalendar RFC refers to entries as
36             "components".) iCalendar defines several types of entries, such as
37             events and to-do lists; each of these corresponds to a subclass of
38             L (though only to-do lists and events are currently
39             implemented). L should be treated as an abstract
40             base class -- all objects created should be of its subclasses. The
41             entire calendar itself (the L object) is also represented
42             as a L object.
43              
44             Each entry has an entry type (such as C or C), a
45             series of "properties", and possibly some sub-entries. (Only the root
46             L object can have sub-entries, except for alarm entries
47             contained in events and to-dos (not yet implemented).)
48              
49             =head1 METHODS
50              
51             =cut
52              
53             =head2 new
54              
55             Creates a new entry object with no properties or sub-entries.
56              
57             =cut
58              
59             sub new {
60 87     87 1 1949 my $class = shift;
61 87         354 my $self = $class->SUPER::new();
62             # ALLOW passing arguments here!
63 87         709 $self->set( properties => {} );
64 87         933 $self->set( entries => [] );
65 87         584 for (@_) {
66 43 100       110 ref $_ eq "HASH" and $self->add_properties( %$_ );
67 43 50       94 ref $_ eq "ARRAY" and $self->add_entries( @$_ );
68             }
69 87         171 return $self;
70             }
71              
72             =head2 as_string [ crlf => C ]
73              
74             Returns the entry as an appropriately formatted string (with trailing
75             newline).
76              
77             Properties are returned in alphabetical order, with multiple
78             properties of the same name returned in the order added. (Property
79             order is unimportant in iCalendar, and this makes testing easier.)
80              
81             If any mandatory property is missing, issues a warning.
82              
83             The string to use as a newline can optionally be specified by giving
84             the a C argument, which defaults to C<\x0d\x0a>, per RFC 2445
85             spec; this option is primarily for backwards compatibility with
86             versions of this module before 0.16.
87              
88             =cut
89              
90             my $uid = 0;
91             sub as_string {
92 58     58 1 5969 my $self = shift;
93 58         189 my %args = (
94             crlf => CRLF,
95             @_
96             );
97 58         244 my $output = $self->header(%args);
98              
99 58         159 my @mandatory = (
100             $self->mandatory_unique_properties,
101             $self->mandatory_repeatable_properties,
102             );
103              
104 58 0 33     150 if (grep {$_ eq "uid"} @mandatory and !defined $self->properties->{uid}
  74   33     217  
105             and $self->auto_uid) {
106             # Per the RFC, create a "persistent, globally unique" UID for this
107             # event; "persistent" in this context does not mean consistent
108             # across time, but rather "unique across all time"
109 0         0 $self->add_property(
110             uid => time() . '-' .$$ . '-' . $uid++ . '@' . Sys::Hostname::hostname()
111             );
112             }
113              
114 58         131 for my $name ( @mandatory ) {
115             carp "Mandatory property for " . ( ref $self ) . " missing: $name"
116             unless $self->properties->{$name}
117 74 100 66     1167 and @{ $self->properties->{$name} };
  74         798  
118             }
119              
120             my @properties = sort {
121             # RFC2445 implies an order (see 4.6 Calendar Components) but does not
122             # require it. However, some applications break if VERSION is not first
123             # (see http://icalvalid.cloudapp.net/Default.aspx and [rt.cpan.org # #65447]).
124 307 100       1077 return -1 if $a eq 'version';
125 299 100       509 return 1 if $b eq 'version';
126 289         454 return $a cmp $b;
127 58         479 } keys %{ $self->properties };
  58         129  
128              
129 58         218 for my $name (@properties) {
130             $output .= $_
131 199         320 for map { $_->as_string(%args) } @{ $self->properties->{$name} };
  204         2151  
  199         403  
132             }
133              
134 58         142 for my $entry ( @{ $self->entries } ) {
  58         185  
135 33         346 $output .= $entry->as_string(%args);
136             }
137 58         553 $output .= $self->footer(%args);
138              
139 58         413 return $output;
140             }
141              
142             =head2 add_entry $entry
143              
144             Adds an entry to this entry. (According to the standard, this should
145             only be called on either a to-do or event entry with an alarm entry,
146             or on a calendar entry (L) with a to-do, event, journal,
147             timezone, or free/busy entry.)
148              
149             Returns true if the entry was successfully added, and false otherwise
150             (perhaps because you tried to add an entry of an invalid type, but
151             this check hasn't been implemented yet).
152              
153             =cut
154              
155             sub add_entry {
156 60     60 1 1094 my $self = shift;
157 60         106 my $entry = shift;
158 60         95 push @{ $self->{entries} }, $entry;
  60         132  
159              
160 60         143 $entry->vcal10( $self->vcal10 );
161 60         1087 $entry->rfc_strict( $self->rfc_strict );
162 60         1399 $entry->auto_uid( $self->auto_uid );
163              
164 60         1141 return $self;
165             }
166              
167             =head2 add_entries $entry1, [$entry2, ...]
168              
169             Convenience function to call C several times with a list
170             of entries.
171              
172             =cut
173              
174             sub add_entries {
175 0     0 1 0 my $self = shift;
176 0         0 $self->add_entry( $_ ) for @_;
177 0         0 return $self;
178             }
179              
180             =head2 entries
181              
182             Returns a reference to the array of subentries of this entry.
183              
184             =cut
185              
186             __PACKAGE__->mk_ro_accessors('entries');
187              
188             =head2 properties
189              
190             Returns a reference to the hash of properties of this entry. The keys
191             are property names and the values are array references containing
192             L objects.
193              
194             =cut
195              
196             __PACKAGE__->mk_ro_accessors('properties');
197              
198             =head2 property
199              
200             Given a property name returns a reference to the array of
201             L objects.
202              
203             =cut
204              
205             sub property {
206 44     44 1 13443 my $self = shift;
207 44         101 my $prop = lc shift;
208 44         177 return $self->{'properties'}->{$prop};
209             }
210              
211             =head2 add_property $propname => $propval
212              
213             Creates a new L object with name C<$propname>
214             and value C<$propval> and adds it to the event.
215              
216             If the property is not known to exist for that object type and does
217             not begin with C, issues a warning.
218              
219             If the property is known to be unique, replaces the original property.
220              
221             To specify parameters for the property, let C<$propval> be a
222             two-element array reference where the first element is the property
223             value and the second element is a hash reference. The keys of the
224             hash are parameter names; the values should be either strings or array
225             references of strings, depending on whether the parameter should have
226             one or multiple (to be comma-separated) values.
227              
228             Examples of setting parameters:
229              
230             # Add a property with a parameter of VALUE set to 'DATE'
231             $event->add_property( rdate => [ $date, { VALUE => 'DATE' } ] );
232              
233             =cut
234              
235             sub add_property {
236 362     362 1 4769 my $self = shift;
237 362         586 my $prop = lc shift;
238 362         495 my $val = shift;
239              
240 362 50       694 return unless defined $prop;
241              
242 362 100 100     840 unless ( $self->is_property($prop) or $prop =~ /^x-/i ) {
243 4         70 carp "Unknown property for " . ( ref $self ) . ": $prop";
244             }
245              
246 362 100       4859 if ( $self->is_unique($prop) ) {
247              
248             # It should be unique, so clear out anything we might have first
249 265         759 $self->properties->{$prop} = [];
250             }
251              
252 362 100       3565 $val = [ $val, {} ] unless ref $val eq 'ARRAY';
253              
254 362         745 my ( $prop_value, $param_hash ) = @$val;
255              
256 362         1004 my $p = Data::ICal::Property->new( $prop => $prop_value, $param_hash );
257 362         768 $p->vcal10( $self->vcal10 );
258              
259 362         6053 push @{ $self->properties->{$prop} }, $p;
  362         684  
260 362         4144 return $self;
261             }
262              
263             =head2 add_properties $propname1 => $propval1, [$propname2 => $propname2, ...]
264              
265             Convenience function to call C several times with a list
266             of properties.
267              
268             This method is guaranteed to call add C on them in the
269             order given, so that unique properties given later in the call will
270             take precedence over those given earlier. (This is unrelated to the
271             order of properties when the entry is rendered as a string, though.)
272              
273             Parameters for the properties are specified in the same way as in
274             C.
275              
276             =cut
277              
278             sub add_properties {
279 13     13 1 2575 my $self = shift;
280              
281 13 50       51 if ( @_ % 2 ) {
282 0         0 carp "Odd number of elements in add_properties call";
283 0         0 return;
284             }
285              
286 13         44 while (@_) {
287 33         70 my $prop = shift;
288 33         49 my $val = shift;
289 33         92 $self->add_property( $prop => $val );
290             }
291 13         49 return $self;
292             }
293              
294             =head2 mandatory_unique_properties
295              
296             Subclasses should override this method (which returns an empty list by
297             default) to provide a list of lower case strings identifying the
298             properties which must appear exactly once in the subclass's entry
299             type.
300              
301             =cut
302              
303 0     0 1 0 sub mandatory_unique_properties { () }
304              
305             =head2 mandatory_repeatable_properties
306              
307             Subclasses should override this method (which returns an empty list by
308             default) to provide a list of lower case strings identifying the
309             properties which must appear at least once in the subclass's entry
310             type.
311              
312             =cut
313              
314 420     420 1 2749 sub mandatory_repeatable_properties { () }
315              
316             =head2 optional_unique_properties
317              
318             Subclasses should override this method (which returns an empty list by
319             default) to provide a list of lower case strings identifying the
320             properties which must appear at most once in the subclass's entry
321             type.
322              
323             =cut
324              
325 240     240 1 407 sub optional_unique_properties { () }
326              
327             =head2 optional_repeatable_properties
328              
329             Subclasses should override this method (which returns an empty list by
330             default) to provide a list of lower case strings identifying the
331             properties which may appear zero, one, or more times in the subclass's
332             entry type.
333              
334             =cut
335              
336 84     84 1 178 sub optional_repeatable_properties { () }
337              
338             =head2 is_property $name
339              
340             Returns a boolean value indicating whether or not the property
341             C<$name> is known to the class (that is, if it's listed in
342             C<(mandatory/optional)_(unique/repeatable)_properties>).
343              
344             =cut
345              
346             sub is_property {
347 362     362 1 496 my $self = shift;
348 362         497 my $name = shift;
349 362         822 return scalar grep { $_ eq $name } $self->mandatory_unique_properties,
  6004         9605  
350             $self->mandatory_repeatable_properties,
351             $self->optional_unique_properties,
352             $self->optional_repeatable_properties;
353             }
354              
355             =head2 is_mandatory $name
356              
357             Returns a boolean value indicating whether or not the property
358             C<$name> is known to the class as mandatory (that is, if it's listed
359             in C).
360              
361             =cut
362              
363             sub is_mandatory {
364 0     0 1 0 my $self = shift;
365 0         0 my $name = shift;
366 0         0 return scalar grep { $_ eq $name } $self->mandatory_unique_properties,
  0         0  
367             $self->mandatory_repeatable_properties;
368             }
369              
370             =head2 is_optional $name
371              
372             Returns a boolean value indicating whether or not the property
373             C<$name> is known to the class as optional (that is, if it's listed in
374             C).
375              
376             =cut
377              
378             sub is_optional {
379 0     0 1 0 my $self = shift;
380 0         0 my $name = shift;
381 0         0 return scalar grep { $_ eq $name } $self->optional_unique_properties,
  0         0  
382             $self->optional_repeatable_properties;
383             }
384              
385             =head2 is_unique $name
386              
387             Returns a boolean value indicating whether or not the property
388             C<$name> is known to the class as unique (that is, if it's listed in
389             C<(mandatory/optional)_unique_properties>).
390              
391             =cut
392              
393             sub is_unique {
394 362     362 1 550 my $self = shift;
395 362         521 my $name = shift;
396 362         684 return scalar grep { $_ eq $name } $self->mandatory_unique_properties,
  3551         5675  
397             $self->optional_unique_properties;
398             }
399              
400             =head2 is_repeatable $name
401              
402             Returns a boolean value indicating whether or not the property
403             C<$name> is known to the class as repeatable (that is, if it's listed
404             in C<(mandatory/optional)_repeatable_properties>).
405              
406             =cut
407              
408             sub is_repeatable {
409 0     0 1 0 my $self = shift;
410 0         0 my $name = shift;
411 0         0 return scalar grep { $_ eq $name } $self->mandatory_repeatable_properties,
  0         0  
412             $self->optional_repeatable_properties;
413             }
414              
415             =head2 ical_entry_type
416              
417             Subclasses should override this method to provide the identifying type
418             name of the entry (such as C or C).
419              
420             =cut
421              
422 0     0 1 0 sub ical_entry_type {'UNDEFINED'}
423              
424             =head2 vcal10 [$bool]
425              
426             Gets or sets a boolean saying whether this entry should be interpreted
427             as vCalendar 1.0 (as opposed to iCalendar 2.0). Generally, you can
428             just set this on your main L object when you construct it;
429             C automatically makes sure that sub-entries end up with the
430             same value as their parents.
431              
432             =cut
433              
434             __PACKAGE__->mk_accessors('vcal10');
435              
436             =head2 rfc_strict [$bool]
437              
438             Gets or sets a boolean saying whether this entry will complain about
439             missing UIDs as per RFC2446. Defaults to false, for backwards
440             compatibility. Generally, you can just set this on your main
441             L object when you construct it; C automatically
442             makes sure that sub-entries end up with the same value as their parents.
443              
444             =cut
445              
446             __PACKAGE__->mk_accessors('rfc_strict');
447              
448             =head2 auto_uid [$bool]
449              
450             Gets or sets a boolean saying whether this entry should automatically
451             generate its own persistently unique UIDs. Defaults to false.
452             Generally, you can just set this on your main L object when
453             you construct it; C automatically makes sure that sub-entries
454             end up with the same value as their parents.
455              
456             =cut
457              
458             __PACKAGE__->mk_accessors('auto_uid');
459              
460             =head2 header
461              
462             Returns the header line for the entry (including trailing newline).
463              
464             =cut
465              
466             sub header {
467 58     58 1 178 my $self = shift;
468 58         154 my %args = (
469             crlf => CRLF,
470             @_
471             );
472 58         198 return 'BEGIN:' . $self->ical_entry_type . $args{crlf};
473             }
474              
475             =head2 footer
476              
477             Returns the footer line for the entry (including trailing newline).
478              
479             =cut
480              
481             sub footer {
482 58     58 1 102 my $self = shift;
483 58         157 my %args = (
484             crlf => CRLF,
485             @_
486             );
487 58         167 return 'END:' . $self->ical_entry_type . $args{crlf};
488             }
489              
490             # mapping of event types to class (under the Data::Ical::Event namespace)
491             my %_generic = (
492             vevent => 'Event',
493             vtodo => 'Todo',
494             vjournal => 'Journal',
495             vfreebusy => 'FreeBusy',
496             vtimezone => 'TimeZone',
497             standard => 'TimeZone::Standard',
498             daylight => 'TimeZone::Daylight',
499             );
500              
501             =head2 parse_object
502              
503             Translate a L sub object into the appropriate
504             L subtype.
505              
506             =cut
507              
508             # TODO: this is currently recursive which could blow the stack -
509             # it might be worth refactoring to make it sequential
510             sub parse_object {
511 66     66 1 128 my ( $self, $object ) = @_;
512              
513 66         126 my $type = $object->{type};
514              
515 66         99 my $new_self;
516              
517             # First check to see if it's generic long name just in case there
518             # event turns out to be a VGENERIC entry type
519 66 100       343 if ( my $class = $_generic{ lc($type) } ) {
    50          
520 48         124 $new_self = $self->_parse_data_ical_generic( $class, $object );
521              
522             # then look for specific overrides
523             } elsif ( my $sub = $self->can( '_parse_' . lc($type) ) ) {
524 18         74 $new_self = $self->$sub($object);
525              
526             # complain
527             } else {
528 0         0 warn "Can't parse type $type yet";
529 0         0 return;
530             }
531              
532             # recurse through sub-objects
533 66         100 foreach my $sub_object ( @{ $object->{objects} } ) {
  66         186  
534 53         159 $new_self->parse_object($sub_object);
535             }
536              
537 66         152 return $self;
538             }
539              
540             # special because we want to use ourselves as the parent
541             sub _parse_vcalendar {
542 13     13   39 my ( $self, $object ) = @_;
543 13         94 $self->_parse_generic_event( $self, $object );
544 13         27 return $self;
545             }
546              
547             # mapping of action types to class (under the Data::Ical::Event::Alarm namespace)
548             my %_action_map = (
549             AUDIO => 'Audio',
550             DISPLAY => 'Display',
551             EMAIL => 'Email',
552             PROCEDURE => 'Procedure',
553             NONE => 'None',
554             URI => 'URI',
555             );
556              
557             # alarms have actions
558             sub _parse_valarm {
559 5     5   14 my ( $parent, $object ) = @_;
560              
561             # ick
562 5         17 my $action = $object->{properties}->{ACTION}->[0]->{value};
563             die "Can't parse VALARM with action $action"
564 5 50       19 unless exists $_action_map{$action};
565              
566 5         63 $action = $_action_map{$action};
567 5         17 my $alarm_class = "Data::ICal::Entry::Alarm::$action";
568 5         356 eval "require $alarm_class";
569 5 50       25 die "Failed to require $alarm_class : $@" if $@;
570              
571 5         41 $alarm_class->import;
572 5         95 my $alarm = $alarm_class->new;
573 5         25 $parent->_parse_generic_event( $alarm, $object );
574 5         30 $parent->add_entry($alarm);
575 5         12 return $alarm;
576             }
577              
578             # generic event handler
579             sub _parse_data_ical_generic {
580 48     48   109 my ( $parent, $class, $object ) = @_;
581              
582 48         118 my $entry_class = "Data::ICal::Entry::$class";
583 48         3034 eval "require $entry_class";
584 48 50       213 die "Failed to require $entry_class : $@" if $@;
585              
586 48         256 $entry_class->import;
587 48         909 my $entry = $entry_class->new;
588 48         137 $entry->vcal10($parent->vcal10);
589 48         935 $parent->_parse_generic_event( $entry, $object );
590 48         208 $parent->add_entry($entry);
591 48         92 return $entry;
592             }
593              
594             # handle transferring of properties
595             sub _parse_generic_event {
596 66     66   137 my ( $parent, $entry, $object ) = @_;
597              
598 66         115 my $p = $object->{properties};
599 66         455 for my $key ( sort keys %$p ) {
600 315         440 foreach my $occurence (@{ $p->{$key} }) {
  315         614  
601 315         410 my $prop;
602              
603             # Unescapes, but only in v2, and not if it's explicitly not TEXT
604 315 100 66     666 if (not $parent->vcal10
      66        
605             and ( not $occurence->{param}
606             or not defined $occurence->{param}{VALUE}
607             or $occurence->{param}{VALUE} eq "TEXT" )
608             )
609             {
610 189         2381 $occurence->{value} =~ s/\\([;,\\])/$1/g;
611 189         384 $occurence->{value} =~ s/\\n/\n/ig;
612             }
613              
614             # handle optional params and 'normal' key/value pairs
615             # TODO: line wrapping?
616 315 100       1653 if ( $occurence->{param} ) {
617 30         72 $prop = [ $occurence->{value}, $occurence->{param} ];
618             } else {
619 285         461 $prop = $occurence->{value};
620             }
621 315         764 $entry->add_property( lc($key) => $prop );
622             }
623             }
624 66         134 return $entry;
625             }
626              
627             =head1 AUTHOR
628              
629             Best Practical Solutions, LLC Emodules@bestpractical.comE
630              
631             =head1 LICENCE AND COPYRIGHT
632              
633             Copyright (c) 2005 - 2020, Best Practical Solutions, LLC. All rights reserved.
634              
635             This module is free software; you can redistribute it and/or
636             modify it under the same terms as Perl itself. See L.
637              
638             =cut
639              
640             1;