view release on metacpan or  search on metacpan

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

    TZNAME             => 'TEXT',
    TZOFFSETFROM       => 'UTC-OFFSET',
    TZOFFSETTO         => 'UTC-OFFSET',
    TZURL              => 'URI',
    ATTENDEE           => 'CAL-ADDRESS',
    CONTACT            => 'TEXT',
    ORGANIZER          => 'CAL-ADDRES',
    'RECURRENCE-ID'    => 'DATE-TIME',
    'RELATED-TO'       => 'TEXT', # actually UID
    URL                => 'URI',
    UID                => 'TEXT',
    EXDATE             => 'DATE-TIME',
    RDATE              => 'DATE-TIME',
    RRULE              => 'RECUR',
    ACTION             => 'LIST*', # actually enum
    REPEAT             => 'INTEGER',
    TRIGGER            => 'DURATION',
    CREATED            => 'DATE-TIME',
    DTSTAMP            => 'DATE-TIME',
    'LAST-MODIFIED'    => 'DATE-TIME',
    SEQUENCE           => 'INTEGER',
    'REQUEST-STATUS'   => 'TEXT',
);

# the icaltzd spec (http://www.w3.org/2002/12/cal/icaltzd#) is pretty
# much derived deterministically from rfc 2445 (now 5445). properties
# are lower case unless hyphenated, in which event they are camelCased.

# however we don't want to use the ical properties on everything,
# notably: created, last modified, geo coords
my %PRED = (
    CREATED         => $NS->dct->created,
    'LAST-MODIFIED' => $NS->dct->modified,
);

# this gives us the correct predicate
sub _predicate_for {
    my ($self, $prop) = @_;

    # get the name
    my $name = lc $prop->key;

    return $PRED{uc $name} if $PRED{uc $name};

    my ($first, @rest) = split /-/, $name;
    $name = $first . join '', map { ucfirst $_ } @rest if @rest;

    $NS->ical->uri($name);
}

# this is a helper for BINARY values.
sub _decode_property {
    my $prop = shift;
    my $enc  = uc($prop->parameters->{ENCODING} || 'BASE64');
    if ($enc eq 'BASE64') {
        # for some reason base64 is not built into Data::ICal.
        return MIME::Base64::decode($prop->value);
    }
    elsif ($enc eq 'QUOTED-PRINTABLE') {
        # QP *is* built in, however.
        return $prop->decoded_value;
    }
    else {
        return;
    }
}

# these get run as faux methods and their job is to insert statements
# into the temporary store.
my %VALS = (
    BINARY        => sub {
        # ohhhhhh this one's gonna be fun.
        my ($self, $prop, $s) = @_;

        # get the literal value
        my $val = _decode_property($prop);
        return unless defined $val;

        my $param  = $prop->parameters;

        # get a suitable content type
        my ($type) = (lc($param->{FMTTYPE} || 'application/octet-stream') =~
                          /^\s*(.*?)(?:\s*;.*)?$/);

        # too bad there isn't a standardized parameter for file names
        my $name = $param->{'X-FILENAME'} || $param->{'X-APPLE-FILENAME'};

        # this is where the securi-tah happens, folks.
        if (defined $name) {
            # remove any space padding
            $name =~ s/^\s*(.*?)\s*$/$1/;
            # scrub the filename of any naughty path info
            $name = Path::Class::File->new($name)->basename if $name ne '';

            # kill the name if all that's left is an empty string
            undef $name if $name eq '';
        }

        # turn the val into an IO object
        my $io = IO::Scalar->new(\$val);

        # now try to resolve the attachment
        my $o = eval { $self->resolve_binary->($self, $io, $type, $name) };
        $self->throw("resolve_binary callback failed: $@") if $@;
        $self->throw('resolve_binary callback returned an invalid value')
              unless _is_really($o, 'RDF::Trine::Node');

        my $p = $self->_predicate_for($prop);
        $self->model->add_statement(statement($s, $p, $o));

        $val;
    },
    BOOLEAN       => sub {
        my ($self, $prop, $s) = @_;

        # postel's law
        my $x = 1 if $prop->value =~ /1|true|on|yes/i;

        # output
        my $o = literal($x ? 'true' : 'false', undef, $NS->xsd->boolean);
        my $p = $self->_predicate_for($prop);