view release on metacpan or  search on metacpan

lib/Data/ICal/Entry.pm  view on Meta::CPAN

=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;

lib/Data/ICal/Entry.pm  view on Meta::CPAN

=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',
);