init III
This commit is contained in:
640
Perl OTRS/Kernel/cpan-lib/Data/ICal/Entry.pm
Normal file
640
Perl OTRS/Kernel/cpan-lib/Data/ICal/Entry.pm
Normal file
@@ -0,0 +1,640 @@
|
||||
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";
|
||||
|
||||
=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;
|
||||
}
|
||||
|
||||
=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;
|
||||
}
|
||||
|
||||
=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;
|
||||
}
|
||||
|
||||
=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;
|
||||
}
|
||||
|
||||
=head2 entries
|
||||
|
||||
Returns a reference to the array of subentries of this entry.
|
||||
|
||||
=cut
|
||||
|
||||
__PACKAGE__->mk_ro_accessors('entries');
|
||||
|
||||
=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');
|
||||
|
||||
=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};
|
||||
}
|
||||
|
||||
=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;
|
||||
}
|
||||
|
||||
=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;
|
||||
}
|
||||
|
||||
=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 { () }
|
||||
|
||||
=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 { () }
|
||||
|
||||
=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 { () }
|
||||
|
||||
=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 { () }
|
||||
|
||||
=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;
|
||||
}
|
||||
|
||||
=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;
|
||||
}
|
||||
|
||||
=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;
|
||||
}
|
||||
|
||||
=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;
|
||||
}
|
||||
|
||||
=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;
|
||||
}
|
||||
|
||||
=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'}
|
||||
|
||||
=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');
|
||||
|
||||
=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');
|
||||
|
||||
=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');
|
||||
|
||||
=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};
|
||||
}
|
||||
|
||||
=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',
|
||||
);
|
||||
|
||||
=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;
|
||||
}
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Best Practical Solutions, LLC E<lt>modules@bestpractical.comE<gt>
|
||||
|
||||
=head1 LICENCE AND COPYRIGHT
|
||||
|
||||
Copyright (c) 2005 - 2015, 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;
|
||||
Reference in New Issue
Block a user