—
—
—
—
—
—
—
—
—
—
—
—
—
—
—
—
—
—
—
—
—
—
—
—
—
—

              
use warnings;
use strict;
package Data::ICal::Entry;
use base qw/Class::Accessor/;
use Data::ICal::Property;
use Sys::Hostname qw();         # For unique UIDs for entries
use Carp;
use constant CRLF => "\x0d\x0a";
HideShow 47 lines of Pod
=head1 NAME
Data::ICal::Entry - Represents an entry in an iCalendar file
=head1 SYNOPSIS
    my $vtodo = Data::ICal::Entry::Todo->new();
    $vtodo->add_property(
    # ... see Data::ICal::Entry::Todo documentation
    );
    $vtodo->add_properties( ... );
    $calendar->add_entry($vtodo);
    $event->add_entry($alarm);
    $event->add_entries($alarm1, ...);
    # or all in one go
    my $vtodo = Data::ICal::Entry::Todo->new( \%props, \@entries );
=head1 DESCRIPTION
A L<Data::ICal::Entry> object represents a single entry in an
iCalendar file.  (Note that the iCalendar RFC refers to entries as
"components".)  iCalendar defines several types of entries, such as
events and to-do lists; each of these corresponds to a subclass of
L<Data::ICal::Entry> (though only to-do lists and events are currently
implemented).  L<Data::ICal::Entry> should be treated as an abstract
base class -- all objects created should be of its subclasses.  The
entire calendar itself (the L<Data::ICal> object) is also represented
as a L<Data::ICal::Entry> object.
Each entry has an entry type (such as C<VCALENDAR> or C<VEVENT>), a
series of "properties", and possibly some sub-entries.  (Only the root
L<Data::ICal> object can have sub-entries, except for alarm entries
contained in events and to-dos (not yet implemented).)
=head1 METHODS
=cut
=head2 new
Creates a new entry object with no properties or sub-entries.
=cut
sub new {
    my $class = shift;
    my $self  = $class->SUPER::new();
    # ALLOW passing arguments here!
    $self->set( properties => {} );
    $self->set( entries    => [] );
    for (@_) {
        ref $_ eq "HASH"  and $self->add_properties( %$_ );
        ref $_ eq "ARRAY" and $self->add_entries( @$_ );
    }
    return $self;
}
HideShow 18 lines of Pod
=head2 as_string [ crlf => C<CRLF> ]
Returns the entry as an appropriately formatted string (with trailing
newline).
Properties are returned in alphabetical order, with multiple
properties of the same name returned in the order added.  (Property
order is unimportant in iCalendar, and this makes testing easier.)
If any mandatory property is missing, issues a warning.
The string to use as a newline can optionally be specified by giving
the a C<crlf> argument, which defaults to C<\x0d\x0a>, per RFC 2445
spec; this option is primarily for backwards compatibility with
versions of this module before 0.16.
=cut
my $uid = 0;
sub as_string {
    my $self = shift;
    my %args = (
        crlf => CRLF,
        @_
    );
    my $output = $self->header(%args);
    my @mandatory = (
        $self->mandatory_unique_properties,
        $self->mandatory_repeatable_properties,
    );
    if (grep {$_ eq "uid"} @mandatory and !defined $self->properties->{uid}
            and $self->auto_uid) {
      # Per the RFC, create a "persistent, globally unique" UID for this
      # event; "persistent" in this context does not mean consistent
      # across time, but rather "unique across all time"
      $self->add_property(
          uid => time() . '-' .$$ . '-' . $uid++ . '@' . Sys::Hostname::hostname()
      );
    }
    for my $name ( @mandatory ) {
        carp "Mandatory property for " . ( ref $self ) . " missing: $name"
            unless $self->properties->{$name}
                and @{ $self->properties->{$name} };
    }
    my @properties = sort {
        # RFC2445 implies an order (see 4.6 Calendar Components) but does not
        # require it.  However, some applications break if VERSION is not first
        # (see http://icalvalid.cloudapp.net/Default.aspx and [rt.cpan.org # #65447]).
        return -1 if $a eq 'version';
        return  1 if $b eq 'version';
        return $a cmp $b;
    } keys %{ $self->properties };
    for my $name (@properties) {
        $output .= $_
            for map { $_->as_string(%args) } @{ $self->properties->{$name} };
    }
    for my $entry ( @{ $self->entries } ) {
        $output .= $entry->as_string(%args);
    }
    $output .= $self->footer(%args);
    return $output;
}
HideShow 13 lines of Pod
=head2 add_entry $entry
Adds an entry to this entry.  (According to the standard, this should
only be called on either a to-do or event entry with an alarm entry,
or on a calendar entry (L<Data::ICal>) with a to-do, event, journal,
timezone, or free/busy entry.)
Returns true if the entry was successfully added, and false otherwise
(perhaps because you tried to add an entry of an invalid type, but
this check hasn't been implemented yet).
=cut
sub add_entry {
    my $self  = shift;
    my $entry = shift;
    push @{ $self->{entries} }, $entry;
    $entry->vcal10( $self->vcal10 );
    $entry->rfc_strict( $self->rfc_strict );
    $entry->auto_uid( $self->auto_uid );
    return $self;
}
HideShow 7 lines of Pod
=head2 add_entries $entry1, [$entry2, ...]
Convenience function to call C<add_entry> several times with a list
of entries.
=cut
sub add_entries {
    my $self  = shift;
    $self->add_entry( $_ ) for @_;
    return $self;
}
HideShow 6 lines of Pod
=head2 entries
Returns a reference to the array of subentries of this entry.
=cut
__PACKAGE__->mk_ro_accessors('entries');
HideShow 8 lines of Pod
=head2 properties
Returns a reference to the hash of properties of this entry.  The keys
are property names and the values are array references containing
L<Data::ICal::Property> objects.
=cut
__PACKAGE__->mk_ro_accessors('properties');
HideShow 7 lines of Pod
=head2 property
Given a property name returns a reference to the array of
L<Data::ICal::Property> objects.
=cut
sub property {
    my $self = shift;
    my $prop = lc shift;
    return $self->{'properties'}->{$prop};
}
HideShow 24 lines of Pod
=head2 add_property $propname => $propval
Creates a new L<Data::ICal::Property> object with name C<$propname>
and value C<$propval> and adds it to the event.
If the property is not known to exist for that object type and does
not begin with C<X->, issues a warning.
If the property is known to be unique, replaces the original property.
To specify parameters for the property, let C<$propval> be a
two-element array reference where the first element is the property
value and the second element is a hash reference.  The keys of the
hash are parameter names; the values should be either strings or array
references of strings, depending on whether the parameter should have
one or multiple (to be comma-separated) values.
Examples of setting parameters:
 # Add a property with a parameter of VALUE set to 'DATE'
 $event->add_property( rdate => [ $date, { VALUE => 'DATE' } ] );
=cut
sub add_property {
    my $self = shift;
    my $prop = lc shift;
    my $val  = shift;
    return unless defined $prop;
    unless ( $self->is_property($prop) or $prop =~ /^x-/i ) {
        carp "Unknown property for " . ( ref $self ) . ": $prop";
    }
    if ( $self->is_unique($prop) ) {
        # It should be unique, so clear out anything we might have first
        $self->properties->{$prop} = [];
    }
    $val = [ $val, {} ] unless ref $val eq 'ARRAY';
    my ( $prop_value, $param_hash ) = @$val;
    my $p = Data::ICal::Property->new( $prop => $prop_value, $param_hash );
    $p->vcal10( $self->vcal10 );
    push @{ $self->properties->{$prop} }, $p;
    return $self;
}
HideShow 15 lines of Pod
=head2 add_properties $propname1 => $propval1, [$propname2 => $propname2, ...]
Convenience function to call C<add_property> several times with a list
of properties.
This method is guaranteed to call add C<add_property> on them in the
order given, so that unique properties given later in the call will
take precedence over those given earlier.  (This is unrelated to the
order of properties when the entry is rendered as a string, though.)
Parameters for the properties are specified in the same way as in
C<add_property>.
=cut
sub add_properties {
    my $self = shift;
    if ( @_ % 2 ) {
        carp "Odd number of elements in add_properties call";
        return;
    }
    while (@_) {
        my $prop = shift;
        my $val  = shift;
        $self->add_property( $prop => $val );
    }
    return $self;
}
HideShow 9 lines of Pod
=head2 mandatory_unique_properties
Subclasses should override this method (which returns an empty list by
default) to provide a list of lower case strings identifying the
properties which must appear exactly once in the subclass's entry
type.
=cut
sub mandatory_unique_properties { () }
HideShow 9 lines of Pod
=head2 mandatory_repeatable_properties
Subclasses should override this method (which returns an empty list by
default) to provide a list of lower case strings identifying the
properties which must appear at least once in the subclass's entry
type.
=cut
sub mandatory_repeatable_properties { () }
HideShow 9 lines of Pod
=head2 optional_unique_properties
Subclasses should override this method (which returns an empty list by
default) to provide a list of lower case strings identifying the
properties which must appear at most once in the subclass's entry
type.
=cut
sub optional_unique_properties { () }
HideShow 9 lines of Pod
=head2 optional_repeatable_properties
Subclasses should override this method (which returns an empty list by
default) to provide a list of lower case strings identifying the
properties which may appear zero, one, or more times in the subclass's
entry type.
=cut
sub optional_repeatable_properties { () }
HideShow 8 lines of Pod
=head2 is_property $name
Returns a boolean value indicating whether or not the property
C<$name> is known to the class (that is, if it's listed in
C<(mandatory/optional)_(unique/repeatable)_properties>).
=cut
sub is_property {
    my $self = shift;
    my $name = shift;
    return scalar grep { $_ eq $name } $self->mandatory_unique_properties,
        $self->mandatory_repeatable_properties,
        $self->optional_unique_properties,
        $self->optional_repeatable_properties;
}
HideShow 8 lines of Pod
=head2 is_mandatory $name
Returns a boolean value indicating whether or not the property
C<$name> is known to the class as mandatory (that is, if it's listed
in C<mandatory_(unique/repeatable)_properties>).
=cut
sub is_mandatory {
    my $self = shift;
    my $name = shift;
    return scalar grep { $_ eq $name } $self->mandatory_unique_properties,
        $self->mandatory_repeatable_properties;
}
HideShow 8 lines of Pod
=head2 is_optional $name
Returns a boolean value indicating whether or not the property
C<$name> is known to the class as optional (that is, if it's listed in
C<optional_(unique/repeatable)_properties>).
=cut
sub is_optional {
    my $self = shift;
    my $name = shift;
    return scalar grep { $_ eq $name } $self->optional_unique_properties,
        $self->optional_repeatable_properties;
}
HideShow 8 lines of Pod
=head2 is_unique $name
Returns a boolean value indicating whether or not the property
C<$name> is known to the class as unique (that is, if it's listed in
C<(mandatory/optional)_unique_properties>).
=cut
sub is_unique {
    my $self = shift;
    my $name = shift;
    return scalar grep { $_ eq $name } $self->mandatory_unique_properties,
        $self->optional_unique_properties;
}
HideShow 8 lines of Pod
=head2 is_repeatable $name
Returns a boolean value indicating whether or not the property
C<$name> is known to the class as repeatable (that is, if it's listed
in C<(mandatory/optional)_repeatable_properties>).
=cut
sub is_repeatable {
    my $self = shift;
    my $name = shift;
    return scalar grep { $_ eq $name } $self->mandatory_repeatable_properties,
        $self->optional_repeatable_properties;
}
HideShow 7 lines of Pod
=head2 ical_entry_type
Subclasses should override this method to provide the identifying type
name of the entry (such as C<VCALENDAR> or C<VTODO>).
=cut
sub ical_entry_type {'UNDEFINED'}
HideShow 10 lines of Pod
=head2 vcal10 [$bool]
Gets or sets a boolean saying whether this entry should be interpreted
as vCalendar 1.0 (as opposed to iCalendar 2.0).  Generally, you can
just set this on your main L<Data::ICal> object when you construct it;
C<add_entry> automatically makes sure that sub-entries end up with the
same value as their parents.
=cut
__PACKAGE__->mk_accessors('vcal10');
HideShow 10 lines of Pod
=head2 rfc_strict [$bool]
Gets or sets a boolean saying whether this entry will complain about
missing UIDs as per RFC2446. Defaults to false, for backwards
compatibility.  Generally, you can just set this on your main
L<Data::ICal> object when you construct it; C<add_entry> automatically
makes sure that sub-entries end up with the same value as their parents.
=cut
__PACKAGE__->mk_accessors('rfc_strict');
HideShow 10 lines of Pod
=head2 auto_uid [$bool]
Gets or sets a boolean saying whether this entry should automatically
generate its own persistently unique UIDs.  Defaults to false.
Generally, you can just set this on your main L<Data::ICal> object when
you construct it; C<add_entry> automatically makes sure that sub-entries
end up with the same value as their parents.
=cut
__PACKAGE__->mk_accessors('auto_uid');
HideShow 6 lines of Pod
=head2 header
Returns the header line for the entry (including trailing newline).
=cut
sub header {
    my $self = shift;
    my %args = (
        crlf => CRLF,
        @_
    );
    return 'BEGIN:' . $self->ical_entry_type . $args{crlf};
}
HideShow 6 lines of Pod
=head2 footer
Returns the footer line for the entry (including trailing newline).
=cut
sub footer {
    my $self = shift;
    my %args = (
        crlf => CRLF,
        @_
    );
    return 'END:' . $self->ical_entry_type . $args{crlf};
}
# mapping of event types to class (under the Data::Ical::Event namespace)
my %_generic = (
    vevent    => 'Event',
    vtodo     => 'Todo',
    vjournal  => 'Journal',
    vfreebusy => 'FreeBusy',
    vtimezone => 'TimeZone',
    standard  => 'TimeZone::Standard',
    daylight  => 'TimeZone::Daylight',
);
HideShow 7 lines of Pod
=head2 parse_object
Translate a L<Text::vFile::asData> sub object into the appropriate
L<Data::iCal::Event> subtype.
=cut
# TODO: this is currently recursive which could blow the stack -
#       it might be worth refactoring to make it sequential
sub parse_object {
    my ( $self, $object ) = @_;
    my $type = $object->{type};
    my $new_self;
    # First check to see if it's generic long name just in case there
    # event turns out to be a VGENERIC entry type
    if ( my $class = $_generic{ lc($type) } ) {
        $new_self = $self->_parse_data_ical_generic( $class, $object );
        # then look for specific overrides
    } elsif ( my $sub = $self->can( '_parse_' . lc($type) ) ) {
        $new_self = $self->$sub($object);
        # complain
    } else {
        warn "Can't parse type $type yet";
        return;
    }
    # recurse through sub-objects
    foreach my $sub_object ( @{ $object->{objects} } ) {
        $new_self->parse_object($sub_object);
    }
    return $self;
}
# special because we want to use ourselves as the parent
sub _parse_vcalendar {
    my ( $self, $object ) = @_;
    $self->_parse_generic_event( $self, $object );
    return $self;
}
# mapping of action types to class (under the Data::Ical::Event::Alarm namespace)
my %_action_map = (
    AUDIO     => 'Audio',
    DISPLAY   => 'Display',
    EMAIL     => 'Email',
    PROCEDURE => 'Procedure',
    NONE      => 'None',
    URI       => 'URI',
);
# alarms have actions
sub _parse_valarm {
    my ( $parent, $object ) = @_;
    # ick
    my $action = $object->{properties}->{ACTION}->[0]->{value};
    die "Can't parse VALARM with action $action"
        unless exists $_action_map{$action};
    $action = $_action_map{$action};
    my $alarm_class = "Data::ICal::Entry::Alarm::$action";
    eval "require $alarm_class";
    die "Failed to require $alarm_class : $@" if $@;
    $alarm_class->import;
    my $alarm = $alarm_class->new;
    $parent->_parse_generic_event( $alarm, $object );
    $parent->add_entry($alarm);
    return $alarm;
}
# generic event handler
sub _parse_data_ical_generic {
    my ( $parent, $class, $object ) = @_;
    my $entry_class = "Data::ICal::Entry::$class";
    eval "require $entry_class";
    die "Failed to require $entry_class : $@" if $@;
    $entry_class->import;
    my $entry = $entry_class->new;
    $entry->vcal10($parent->vcal10);
    $parent->_parse_generic_event( $entry, $object );
    $parent->add_entry($entry);
    return $entry;
}
# handle transferring of properties
sub _parse_generic_event {
    my ( $parent, $entry, $object ) = @_;
    my $p = $object->{properties};
    for my $key ( sort keys %$p ) {
        foreach my $occurence (@{ $p->{$key} }) {
            my $prop;
            # Unescapes, but only in v2, and not if it's explicitly not TEXT
            if (not $parent->vcal10
                and (  not $occurence->{param}
                    or not defined $occurence->{param}{VALUE}
                    or $occurence->{param}{VALUE} eq "TEXT" )
                )
            {
                $occurence->{value} =~ s/\\([;,\\])/$1/g;
                $occurence->{value} =~ s/\\n/\n/ig;
            }
            # handle optional params and 'normal' key/value pairs
            # TODO: line wrapping?
            if ( $occurence->{param} ) {
                $prop = [ $occurence->{value}, $occurence->{param} ];
            } else {
                $prop = $occurence->{value};
            }
            $entry->add_property( lc($key) => $prop );
        }
    }
    return $entry;
}
HideShow 13 lines of Pod
=head1 AUTHOR
Best Practical Solutions, LLC E<lt>modules@bestpractical.comE<gt>
=head1 LICENCE AND COPYRIGHT
Copyright (c) 2005 - 2020, Best Practical Solutions, LLC.  All rights reserved.
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself. See L<perlartistic>.
=cut
1;