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   67 use warnings;
  13         17  
  13         419  
2 13     13   49 use strict;
  13         24  
  13         508  
3              
4             package Data::ICal::Entry;
5 13     13   54 use base qw/Class::Accessor/;
  13         17  
  13         7526  
6 13     13   25940 use Data::ICal::Property;
  13         26  
  13         84  
7 13     13   6810 use Sys::Hostname qw(); # For unique UIDs for entries
  13         11391  
  13         292  
8 13     13   72 use Carp;
  13         16  
  13         776  
9              
10 13     13   65 use constant CRLF => "\x0d\x0a";
  13         14  
  13         22173  
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 1282 my $class = shift;
61 87         329 my $self = $class->SUPER::new();
62             # ALLOW passing arguments here!
63 87         940 $self->set( properties => {} );
64 87         721 $self->set( entries => [] );
65 87         377 for (@_) {
66 43 100       84 ref $_ eq "HASH" and $self->add_properties( %$_ );
67 43 50       101 ref $_ eq "ARRAY" and $self->add_entries( @$_ );
68             }
69 87         151 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 57     57 1 3930 my $self = shift;
93 57         146 my %args = (
94             crlf => CRLF,
95             @_
96             );
97 57         202 my $output = $self->header(%args);
98              
99 57         171 my @mandatory = (
100             $self->mandatory_unique_properties,
101             $self->mandatory_repeatable_properties,
102             );
103              
104 57 0 33     115 if (grep {$_ eq "uid"} @mandatory and !defined $self->properties->{uid}
  74   33     172  
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 57         89 for my $name ( @mandatory ) {
115 74         625 carp "Mandatory property for " . ( ref $self ) . " missing: $name"
116             unless $self->properties->{$name}
117 74 100 66     922 and @{ $self->properties->{$name} };
118             }
119              
120 290 100       783 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 57         138 return -1 if $a eq 'version';
125 284 100       371 return 1 if $b eq 'version';
126 274         262 return $a cmp $b;
127 57         276 } keys %{ $self->properties };
128              
129 57         144 for my $name (@properties) {
130 202         1537 $output .= $_
131 197         177 for map { $_->as_string(%args) } @{ $self->properties->{$name} };
  197         366  
132             }
133              
134 57         66 for my $entry ( @{ $self->entries } ) {
  57         189  
135 33         284 $output .= $entry->as_string(%args);
136             }
137 57         416 $output .= $self->footer(%args);
138              
139 57         284 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 714 my $self = shift;
157 60         62 my $entry = shift;
158 60         51 push @{ $self->{entries} }, $entry;
  60         105  
159              
160 60         117 $entry->vcal10( $self->vcal10 );
161 60         657 $entry->rfc_strict( $self->rfc_strict );
162 60         662 $entry->auto_uid( $self->auto_uid );
163              
164 60         593 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 9001 my $self = shift;
207 44         76 my $prop = lc shift;
208 44         159 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 361     361 1 2897 my $self = shift;
237 361         375 my $prop = lc shift;
238 361         322 my $val = shift;
239              
240 361 50       568 return unless defined $prop;
241              
242 361 100 100     576 unless ( $self->is_property($prop) or $prop =~ /^x-/i ) {
243 4         73 carp "Unknown property for " . ( ref $self ) . ": $prop";
244             }
245              
246 361 100       4459 if ( $self->is_unique($prop) ) {
247              
248             # It should be unique, so clear out anything we might have first
249 264         612 $self->properties->{$prop} = [];
250             }
251              
252 361 100       2544 $val = [ $val, {} ] unless ref $val eq 'ARRAY';
253              
254 361         436 my ( $prop_value, $param_hash ) = @$val;
255              
256 361         896 my $p = Data::ICal::Property->new( $prop => $prop_value, $param_hash );
257 361         612 $p->vcal10( $self->vcal10 );
258              
259 361         3247 push @{ $self->properties->{$prop} }, $p;
  361         551  
260 361         2914 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 2207 my $self = shift;
280              
281 13 50       52 if ( @_ % 2 ) {
282 0         0 carp "Odd number of elements in add_properties call";
283 0         0 return;
284             }
285              
286 13         42 while (@_) {
287 32         40 my $prop = shift;
288 32         39 my $val = shift;
289 32         74 $self->add_property( $prop => $val );
290             }
291 13         22 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 418     418 1 1885 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 321 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 103 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 361     361 1 281 my $self = shift;
348 361         300 my $name = shift;
349 361         681 return scalar grep { $_ eq $name } $self->mandatory_unique_properties,
  5973         6110  
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 361     361 1 300 my $self = shift;
395 361         307 my $name = shift;
396 361         597 return scalar grep { $_ eq $name } $self->mandatory_unique_properties,
  3532         3642  
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 57     57 1 61 my $self = shift;
468 57         100 my %args = (
469             crlf => CRLF,
470             @_
471             );
472 57         158 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 57     57 1 64 my $self = shift;
483 57         120 my %args = (
484             crlf => CRLF,
485             @_
486             );
487 57         137 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 73 my ( $self, $object ) = @_;
512              
513 66         88 my $type = $object->{type};
514              
515 66         60 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       270 if ( my $class = $_generic{ lc($type) } ) {
    50          
520 48         117 $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         45 $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         82 foreach my $sub_object ( @{ $object->{objects} } ) {
  66         166  
534 53         112 $new_self->parse_object($sub_object);
535             }
536              
537 66         147 return $self;
538             }
539              
540             # special because we want to use ourselves as the parent
541             sub _parse_vcalendar {
542 13     13   16 my ( $self, $object ) = @_;
543 13         47 $self->_parse_generic_event( $self, $object );
544 13         25 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   7 my ( $parent, $object ) = @_;
560              
561             # ick
562 5         11 my $action = $object->{properties}->{ACTION}->[0]->{value};
563 5 50       14 die "Can't parse VALARM with action $action"
564             unless exists $_action_map{$action};
565              
566 5         7 $action = $_action_map{$action};
567 5         9 my $alarm_class = "Data::ICal::Entry::Alarm::$action";
568 5         279 eval "require $alarm_class";
569 5 50       20 die "Failed to require $alarm_class : $@" if $@;
570              
571 5         34 $alarm_class->import;
572 5         66 my $alarm = $alarm_class->new;
573 5         15 $parent->_parse_generic_event( $alarm, $object );
574 5         17 $parent->add_entry($alarm);
575 5         9 return $alarm;
576             }
577              
578             # generic event handler
579             sub _parse_data_ical_generic {
580 48     48   47 my ( $parent, $class, $object ) = @_;
581              
582 48         78 my $entry_class = "Data::ICal::Entry::$class";
583 48         2676 eval "require $entry_class";
584 48 50       182 die "Failed to require $entry_class : $@" if $@;
585              
586 48         231 $entry_class->import;
587 48         634 my $entry = $entry_class->new;
588 48         113 $entry->vcal10($parent->vcal10);
589 48         615 $parent->_parse_generic_event( $entry, $object );
590 48         117 $parent->add_entry($entry);
591 48         70 return $entry;
592             }
593              
594             # handle transferring of properties
595             sub _parse_generic_event {
596 66     66   89 my ( $parent, $entry, $object ) = @_;
597              
598 66         83 my $p = $object->{properties};
599 66         324 for my $key ( sort keys %$p ) {
600 315         254 foreach my $occurence (@{ $p->{$key} }) {
  315         457  
601 315         210 my $prop;
602              
603             # Unescapes, but only in v2, and not if it's explicitly not TEXT
604 315 100 66     567 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         1740 $occurence->{value} =~ s/\\([;,\\])/$1/g;
611 189         296 $occurence->{value} =~ s/\\n/\n/ig;
612             }
613              
614             # handle optional params and 'normal' key/value pairs
615             # TODO: line wrapping?
616 315 100       1208 if ( $occurence->{param} ) {
617 30         96 $prop = [ $occurence->{value}, $occurence->{param} ];
618             } else {
619 285         316 $prop = $occurence->{value};
620             }
621 315         815 $entry->add_property( lc($key) => $prop );
622             }
623             }
624 66         111 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 - 2015, 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;