iCalendar event with VTIMEZONE, using Perl, DateTime, and Data::ICal

icalendar.pl

#!/usr/bin/env perl

use v5.14;
use strict;
use warnings;
use utf8;
use open qw<:encoding(UTF-8) :std>;

use Data::ICal::Entry::Event;
use Data::ICal::Entry::TimeZone::Daylight;
use Data::ICal::Entry::TimeZone::Standard;
use Data::ICal::Entry::TimeZone;
use Data::ICal;
use DateTime::Duration;
use DateTime::Format::ICal;
use DateTime::TimeZone;
use DateTime;
use English qw<-no_match_vars>;

my $utc_start = DateTime->new(
    year      => 2018,
    month     => 4,
    day       => 5,
    hour      => 12,
    minute    => 30,
    second    => 0,
    time_zone => 'UTC',
);

my $utc_end = $utc_start->clone->add(minutes => 60);

my $ical = Data::ICal->new(rfc_strict => 1);

$ical->add_properties(method => 'PUBLISH');

my $tzid      = 'Europe/London';
my $vtimezone = Data::ICal::Entry::TimeZone->new;

$vtimezone->add_properties(tzid => $tzid);

my $tz_observance_start = tz_observance($utc_start, $tzid);
my $tz_observance_end   = tz_observance($utc_end,   $tzid);

$vtimezone->add_entry($tz_observance_start);
$vtimezone->add_entry($tz_observance_end)
    if $tz_observance_start->property('dtstart')->[0]->value
    ne $tz_observance_end->property('dtstart')->[0]->value;

$ical->add_entry($vtimezone);

my $local_start = $utc_start->clone->set_time_zone($tzid);
my $local_end   = $utc_end->clone->set_time_zone($tzid);
my $vevent      = Data::ICal::Entry::Event->new;
my $uid         = ical_uid();
my $dtstamp     = DateTime::Format::ICal->format_datetime(DateTime->now);
my $dtstart     = DateTime::Format::ICal->format_datetime($local_start);
my $dtend       = DateTime::Format::ICal->format_datetime($local_end);

$vevent->add_properties(
    uid         => $uid,
    dtstamp     => $dtstamp,
    dtstart     => formatted_string_to_prop($dtstart),
    dtend       => formatted_string_to_prop($dtend),
    location    => 'Somewhere',
    summary     => 'My summary',
    description => 'My description',
    organizer   => 'organizer@example.com',
    attendee    => ['mailto:attendee@example.com', {
        ROLE => 'OPT-PARTICIPANT',
        RSVP => 'FALSE',
        CN   => 'The Attendee',
    }],
);

$ical->add_entry($vevent);

say $ical->as_string;

sub ical_uid {
    return sprintf '%s-%s@%s',
        DateTime::Format::ICal->format_datetime( DateTime->now ),
        $PID,
        '@example.com';
}

sub formatted_string_to_prop {
    my ($str) = @_;

    # TZID=Europe/London:20180405T143000
    my @parts = split /:/xms, $str;
    my $value = pop @parts;
    my %props = map { split /=/xms } @parts;

    return [$value, \%props];
}

sub tz_observance {
    my ($dt, $tz_name) = @_;

    # A VTIMEZONE requires at least one of the "STANDARD" or "DAYLIGHT"
    # sub-components.  From RFC 5545:
    #
    # The collection of properties that are used to define the "STANDARD" and
    # "DAYLIGHT" sub-components include:

    # > The mandatory "DTSTART" property gives the effective onset date and
    # > local time for the time zone sub-component definition.  "DTSTART" in
    # > this usage MUST be specified as a date with a local time value.

    # > The mandatory "TZOFFSETFROM" property gives the UTC offset that is in
    # > use when the onset of this time zone observance begins.
    #
    # To make that more clear, "DTSTART" is actually the local time at which
    # the *previous* time zone observance ends.  For example, at 1967-10-29
    # 02:00:00 in New York, the clocks were put back by one hour to 01:00:00.
    # "DTSTART" must be be 02:00:00, not 01:00:00.  The tz database gives the
    # local start time for EST as 01:00:00.  So we need to get the local *end*
    # time of the previous time zone observance.

    # Find the start and end times of the time zone observance in which our UTC
    # time occurs.
    my $to_span = DateTime::TimeZone::Span->new(
        name      => $tz_name,
        date_time => $dt,
    );

    # Get the Rata Die seconds for the start of the offset observance.
    my $to_start_utc = $to_span->utc_start;

    # Subtract one second from the start of the observance to give us a Rata
    # Die seconds value that occurs in the *previous* time zone observance...
    my $tmp_dt = DateTime::RataDie->new(
        rd_seconds => $to_start_utc - 1,
    )->as_datetime;

    # ...from which we can get the start and end times of the previous time
    # zone observance...
    my $from_span = DateTime::TimeZone::Span->new(
        name      => $tz_name,
        date_time => $tmp_dt,
    );

    my $from_end_local = $from_span->local_end;
    my $from_dt        = DateTime::RataDie->new(
        rd_seconds => $from_end_local,
    )->as_datetime;

    my $class = $to_span->is_dst
        ? 'Data::ICal::Entry::TimeZone::Daylight'
        : 'Data::ICal::Entry::TimeZone::Standard';

    my $tz_observance = $class->new;
    $tz_observance->add_properties(
        tzname       => $to_span->short_name,
        dtstart      => DateTime::Format::ICal->format_datetime($from_dt),
        tzoffsetfrom => DateTime::TimeZone->offset_as_string($from_span->offset),
        tzoffsetto   => DateTime::TimeZone->offset_as_string($to_span->offset),
    );

    return $tz_observance;
}

BEGIN {
    package DateTime::TimeZone::Span;

    use Const::Fast;
    use DateTime::TimeZone;

    const my $UTC_START   => 0;
    const my $UTC_END     => 1;
    const my $LOCAL_START => 2;
    const my $LOCAL_END   => 3;
    const my $OFFSET      => 4;
    const my $IS_DST      => 5;
    const my $SHORT_NAME  => 6;

    sub new {
        my ($class, %args) = @_;

        my $tz   = DateTime::TimeZone->new(name => $args{name});
        my $span = $tz->_span_for_datetime('utc', $args{date_time});

        return bless {
            name      => $args{name},
            date_time => $args{date_time},
            time_zone => $tz,
            span      => $span,
        }, $class;
    }

    sub utc_start {
        my ($self) = @_;

        return $self->{span}[$UTC_START];
    }

    sub utc_end {
        my ($self) = @_;

        return $self->{span}[$UTC_END];
    }

    sub local_start {
        my ($self) = @_;

        return $self->{span}[$LOCAL_START];
    }

    sub local_end {
        my ($self) = @_;

        return $self->{span}[$LOCAL_END];
    }

    sub offset {
        my ($self) = @_;

        return $self->{span}[$OFFSET];
    }

    sub is_dst {
        my ($self) = @_;

        return $self->{span}[$IS_DST];
    }

    sub short_name {
        my ($self) = @_;

        return $self->{span}[$SHORT_NAME];
    }
}

BEGIN {
    package DateTime::RataDie;

    use Const::Fast;
    use DateTime;
    use DateTime::TimeZone;

    const my $SECONDS_PER_DAY => 60 * 60 * 24;

    sub new {
        my ($class, %args) = @_;

        return bless {rd_seconds => $args{rd_seconds}}, $class;
    }

    sub utc_rd_values {
        my ($self) = @_;

        my $rd_days    = int($self->{rd_seconds} / $SECONDS_PER_DAY);
        my $rd_seconds = $self->{rd_seconds} - $rd_days * $SECONDS_PER_DAY;

        return ($rd_days, $rd_seconds, 0);
    }

    sub time_zone {
        DateTime::TimeZone->new(name => 'floating');
    }

    sub as_datetime {
        my ($self) = @_;

        return DateTime->from_object(object => $self);
    }
}