—
—
—

              
package Tie::iCal;
use strict;
require Exporter;
our $VERSION = 0.15;
our @ISA     = qw(Exporter);
use Tie::File;
HideShow 71 lines of Pod
=head1 NAME
Tie::iCal - Tie iCal files to Perl hashes.
=head1 VERSION
This document describes version 0.14 released 1st September 2006.
=head1 SYNOPSIS
        use Tie::iCal;
         
        tie %my_events, 'Tie::iCal', "mycalendar.ics" or die "Failed to tie file!\n";
        tie %your_events, 'Tie::iCal', "yourcalendar.ics" or die "Failed to tie file!\n";
         
        $my_events{"A-NEW-UNIQUE-ID"} = [
                'VEVENT',
                {
                        'SUMMARY' => 'Bastille Day Party',
                        'DTSTAMP' => '19970714T170000Z',
                        'DTEND' => '19970715T035959Z',
                }
        ];
         
        tie %our_events, 'Tie::iCal', "ourcalendar.ics" or die "Failed to tie file!\n";
         
        # assuming %my_events and %your_events
        # have no common keys (unless that's your intention)
        #
        while (my($uid,$event) = each(%my_events)) {
                $our_events{$uid} = $event;     
        }
        while (my($uid,$event) = each(%your_events)) {
                $our_events{$uid} = $event;
        }
         
        untie %our_events;
        untie %your_events;
        untie %my_events;
=head1 DEPENDENCIES
        Tie::File
=head1 DESCRIPTION
Tie::iCal represents an RFC2445 iCalendar file as a Perl hash. Each key in the hash represents
an iCalendar component like VEVENT, VTODO or VJOURNAL. Each component in the file must have
a unique UID property as specified in the RFC 2445. A file containing non-unique UIDs can
be converted to have only unique UIDs (see samples/uniquify.pl).
The module makes very little effort in understanding what each iCalendar property means and concentrates
on the format of the iCalendar file only.
=head1 FILE LOCKING
The Tie::iCal object returned by tie can also be used to access the underlying Tie::File object.
This is accessable via the 'A' class variable.
This may be useful for file locking.
        my $ical = tie %events, 'Tie::iCal', "mycalendar.ics";
        $ical->{A}->flock;
=head1 DATES
The iCalendar specification uses a special format for dates. This module makes no effort in trying
to interpret dates in this format. You should look at the Date::ICal module that can convert between
Unix epoch dates and iCalendar date strings.
=cut
sub TIEHASH {
        my ($p, $f, %O) = @_;
         
        tie my @a, 'Tie::File', $f, recsep => "\r\n" or die "failed to open ical file\n";
        $O{A} = \@a; # file array
        $O{i} = 0;   # current file index for FIRSTKEY and NEXTKEY
        $O{C} = ();  # uid to index cache
         
        bless \%O => $p;
}
sub FETCH {
        my $self = shift;
        my $uid  = shift;
         
        my $index = $self->seekUid($uid);
         
        return defined $index ? $self->toHash($index) : undef;
}
sub EXISTS {
        my $self = shift;
        my $uid  = shift;
         
        my $index = $self->seekUid($uid);
        return defined $index ? 1 : 0;
}
sub FIRSTKEY {
        my $self = shift;
         
        $self->{i} = 0;
        for my $line (@{$self->{A}}) {
                if (substr($line, 0, 3) eq 'UID') {
                        if ($self->unfold($self->{i}) =~ /^UID.*:(.*)$/) {
                                $self->{C}->{$1} = $self->{i}; # cache in any case
                                return $1;
                        } else {
                                warn("FIRSTKEY: discovered illegal UID property format, should be like UID;...:..., ignoring for now\n");
                        }
                }
                $self->{i}++;
        }
}
sub NEXTKEY {
        my $self = shift;
         
        # start search one line after the current point
        my $start_idx = ++$self->{i};
        for my $line (@{$self->{A}}[$start_idx .. (@{$self->{A}} - 1)]) {
                if ($line =~ m/^UID/) {
                        if ($self->unfold($self->{i}) =~ /^UID.*:(.*)$/) {
                                $self->{C}->{$1} = $self->{i}; # cache in any case
                                return $1;
                        } else {
                                warn("NEXTKEY: discovered illegal UID property format, should be like UID;...:..., ignoring for now\n");
                        }
                }
                $self->{i}++;
        }
        return undef;
}
sub SCALAR {
        my $self = shift;
         
        my $count = 0;
        for my $line (@{$self->{A}}) {
                $count++ if substr($line, 0, 3) eq 'UID';
        }
        return $count;
}
sub ceil {
    return int($_[0]) + (int($_[0]) != $_[0]);
}
sub fold {
    my $MAXLENGTH = 75;
    my @A;
    foreach my $string (@_) {
        my @B = unpack("A$MAXLENGTH" x (&ceil(length($string)/$MAXLENGTH)), $string);
        push @A, $B[0], map { ' '.$_ } @B[1..$#B];
    }
    return @A;
}
sub STORE {
        my $self = shift;
        my $uid = shift;
        my $c = shift;
         
        die "event must be array!\n" if ref $c ne 'ARRAY';
        $self->DELETE($uid);
     
        push @{$self->{A}}, fold($self->toiCal($uid, $c));
}
sub DELETE {
        my $self = shift;
        my $uid  = shift;
         
        my $index = $self->seekUid($uid);
         
        return defined $index ? $self->removeComponent($index) : 0;
}
sub CLEAR {
        my $self  = shift;
         
        @{$self->{A}} = ();
}
sub DESTROY {
  my $self = shift;
  untie $self->{A};
}
sub debug {
        my $self = shift;
        print(STDERR shift, "\n") if $self->{debug};
}
sub unfold {
        my $self = shift;
        my $index = shift;
         
        my $result = ${$self->{A}}[$index];
        my $i = 1;
        until (${$self->{A}}[$index + $i] !~ /^ (.*)$/s) {
                $result .= $1;
                $i++;
        }
        $self->debug("unfolded index $index to $result");
        return $result;
}
sub seekUid {
        my $self = shift;
        my $uid  = shift;
         
        my $index;
         
        # check cache
        #
        if (exists $self->{C}->{$uid}) {
                $self->debug("found cached index for $uid, checking..");
                $index = $self->{C}->{$uid};
                if ($self->unfold($index) =~ /^UID.*:(.*)$/) {
                        if ($1 eq $uid) {
                                $self->debug("found key $uid in cache");
                                return $index;
                        } else {
                                $self->debug("could not find key $uid in cache, deleting");
                                delete $self->{C}->{$uid};
                        }
                } else {
                        warn("seekUid: discovered illegal UID property format, should be like UID;...:..., ignoring for now\n");
                }
        }
         
        # not in cache then lets search the file
        #
        $index = 0;
        for my $line (@{$self->{A}}) {
                if (substr($line, 0, 3) eq 'UID') {
                        if ($self->unfold($index) =~ /^UID.*:(.*)$/) {
                                $self->{C}->{$1} = $index; # cache in any case
                                if ($1 eq $uid) {
                                        $self->debug("found key $uid");
                                        return $index;
                                }
                        } else {
                                warn("discovered illegal UID property format, should be like UID;...:..., ignoring for now\n");
                        }
                }
                $index++;
        }
         
        # doesn't exist!
        #
        return undef;   
}
sub removeComponent {
        my $self = shift;
        my $index = shift;
         
        my $i;
        $i = 0; $i++ until ${$self->{A}}[$index - $i] =~ /^BEGIN:(\w+)$/; my $si = $index - $i;
        my $component = $1;
        $i = 0; $i++ until ${$self->{A}}[$index + $i] =~ /^END:$component/; my $fi = $index + $i;
        $self->debug("component $component found between [$si, $fi]");
         
        splice @{$self->{A}}, $si, $fi - $si + 1;    
}
HideShow 133 lines of Pod
=head1 How Tie::iCal interprets iCal files
Tie::iCal interprets files by mapping iCal components into Perl hash keys and
iCal content lines into various Perl arrays and hashes.
=head2 Components
An iCal component such as VEVENT, VTODO or VJOURNAL maps to a hash key:-
        BEGIN:VEVENT
        UID:a_unique_uid
        NAME1:VALUE1
        ..
        END:VEVENT
corresponds to
        $events{'a_unique_uid'} = ['VEVENT', {'NAME1' => 'VALUE1'}]
=head2 Subcomponents
An iCal subcomponent such as VALARM maps to a list of hash keys:-
        BEGIN:VALARM
        TRIGGER;VALUE=DURATION:-PT1S
        TRIGGER;VALUE=DURATION:-PT1S
        END:VALARM
        BEGIN:VALARM
        X-TIE-ICAL;VALUE=ANOTHER:HERE
        X-TIE-ICAL:HERE2
        X-TIE-ICAL-NAME:HERE2
        END:VALARM
corresponds to
        'VALARM' => [
                {
                        'TRIGGER' => [
                                [{'VALUE' => 'DURATION'},'-PT1S'],
                                [{'VALUE' => 'DURATION'},'-PT1S']
                        ]
                },
                {
                        'X-TIE-ICAL' => [
                                [{'VALUE' => 'ANOTHER'},'HERE'],
                                ['HERE2']
                        ],
                        'X-TIE-ICAL-NAME' => 'HERE2'
                }
        ]
To see how individual content lines are formed see below.
=head2 Content Lines
Once unfolded, a content line may look like:-
    NAME;PARAM1=PVAL1;PARAM2=PVAL2;...:VALUE1,VALUE2,...
having an equivalent perl data structure like: -
    'NAME' => [{'PARAM1'=>'PVAL1', 'PARAM2'=>'PVAL2', ..}, 'VALUE1', 'VALUE2', ..]
or
    NAME:VALUE1,VALUE2,...
having an equivalent perl data structure like: -
    'NAME' => ['VALUE1', 'VALUE2', ..]
or
    NAME:VALUE
having an equivalent perl data structure like: -
    'NAME' => 'VALUE'
An blank value is mapped from
        NAME:
to 
        'NAME' => ''
Multiple contentlines with same name, i.e. FREEBUSY, ATTENDEE:-
    NAME;PARAM10=PVAL10;PARAM20=PVAL20;...:VALUE10,VALUE20,...
    NAME;PARAM11=PVAL11;PARAM21=PVAL21;...:VALUE11,VALUE21,...
    ...
having an equivalent perl data structure like: -
    'NAME' => [ 
        [{'PARAM10'=>'PVAL10', 'PARAM20'=>'PVAL20', ..}, 'VALUE10', 'VALUE20', ..],
        [{'PARAM11'=>'PVAL11', 'PARAM21'=>'PVAL21', ..}, 'VALUE11', 'VALUE21', ..],
        ...
    ]
or
    NAME:VALUE10,VALUE20,...
    NAME:VALUE11,VALUE21,...
    ...
having an equivalent perl data structure like: -
    'NAME' => [ 
        ['VALUE10', 'VALUE20', ..],
        ['VALUE11', 'VALUE21', ..],
        ...
    ]
or in a mixed form, i.e.
    NAME:VALUE10,VALUE20,...
    NAME;PARAM11=PVAL11;PARAM21=PVAL21:VALUE11,VALUE21,...
    NAME:VALUE12,VALUE22,...
    ...
having an equivalent perl data structure like: -
    'NAME' => [ 
        ['VALUE10', 'VALUE20', ..],
        [{'PARAM11'=>'PVAL11', 'PARAM21'=>'PVAL21', ..}, 'VALUE11', 'VALUE21', ..],
        ['VALUE12', 'VALUE22', ..],
        ...
    ]
=cut
sub toiCal {
        my $self = shift;
        my $uid = shift;
    my $c = shift;
    my $excludeComponent = shift;
        my @lines;
        my ($component, $e) = $excludeComponent ? (undef, $c) : @$c;
    push @lines, "BEGIN:VCALENDAR", "VERSION:2.0", "PRODID:-//Numen Inest/NONSGML Tie::iCal $VERSION//EN", "BEGIN:$component", "UID:$uid" if ! $excludeComponent;
    foreach my $name (keys %$e) {
                if ($name eq 'RRULE') {
            if (ref($$e{$name}) ne 'HASH') {
                warn "RRULE property should be expressed as a hash, ignoring..\n";
            } else {
                my @rrule;
                foreach my $k (keys %{$$e{$name}}) {
                    push @rrule, ref(${$$e{$name}}{$k}) eq 'ARRAY' ? "$k=".join(',', @{${$$e{$name}}{$k}}) : "$k=".${$$e{$name}}{$k}; 
                }
                push @lines, "$name:".join(';',@rrule); 
            }
                } elsif (ref(\$$e{$name}) eq 'SCALAR') {
                        push @lines, "$name:$$e{$name}";
                } elsif (ref($$e{$name}) eq 'ARRAY') {
                        if (@{$$e{$name}} && !grep({ref($_) ne 'HASH'} @{$$e{$name}})) { # strict list of hashes => we have a subcomponent
                                push @lines, "BEGIN:$name";
                foreach my $sc (@{$$e{$name}}) {
                    push @lines, $self->toiCal(undef, $sc, 1);
                }
                push @lines, "END:$name";
                        } elsif (@{$$e{$name}} && !grep({ref($_) ne 'ARRAY'} @{$$e{$name}})) { # strict list of arrays => we have several content lines
                foreach my $cl (@{$$e{$name}}) {
                                if (ref(${$cl}[0]) eq 'HASH') { # we have params
                                                my ($params, @values) = @{$cl};
                                        push @lines, "$name;".join(";", map { "$_=$$params{$_}" } keys(%$params)).":".join(',',@values);
                                        } else { # we only have values
                                                push @lines, "$name:".join(',',@{$cl});
                                        }
                }
            } else {
                                my ($params, @values) = @{$$e{$name}};
                                push @lines, "$name;".join(";", map { "$_=$$params{$_}" } keys(%$params)).":".join(',',@values);
                        }
                } else {
                        warn "ignoring unimplemented ",ref(\${$e}{$name}),"  ->  ",$name."\n";
                }
        }
    push @lines, "END:$component", "END:VCALENDAR" if ! $excludeComponent;
         
        return @lines;
}
# taken from Text::ParseWords without single quote as quote char
# and keep flag
#
sub parse_line {
        # We will be testing undef strings
        no warnings;
        use re 'taint'; # if it's tainted, leave it as such
    my($delimiter, $line) = @_;
    my($word, @pieces);
    while (length($line)) {
                $line =~ s/^(["])                                                               # a $quote
                        ((?:\\.|(?!\1)[^\\])*)                                          # and $quoted text
                        \1                                                                                      # followed by the same quote
                        |                                                                                       # --OR--
                        ^((?:\\.|[^\\"])*?)                                             # an $unquoted text
                        (\Z(?!\n)|(?-x:$delimiter)|(?!^)(?=["]))  
                                                                                                                # plus EOL, delimiter, or quote
                //xs or return;         # extended layout
                my($quote, $quoted, $unquoted, $delim) = ($1, $2, $3, $4);
                return() unless( defined($quote) || length($unquoted) || length($delim));
                $quoted = "$quote$quoted$quote";
        $word .= defined $quote ? $quoted : $unquoted;
  
        if (length($delim)) {
            push(@pieces, $word);
            undef $word;
        }
        if (!length($line)) {
            push(@pieces, $word);
                }
    }
    return(@pieces);
}
sub toHash {
        my $self = shift;
        my $index = shift;
        my $excludeComponent = shift;
         
        my $i;
        $i = 0; $i++ until ${$self->{A}}[$index - $i] =~ /^BEGIN:(\w+)$/; my $si = $index - $i;
        my $component = $1;
        $i = 0; $i++ until ${$self->{A}}[$index + $i] =~ /^END:$component/; my $fi = $index + $i;
        $self->debug("component $component found between [$si, $fi]");
         
        my %e;
        my $subComponent = '';
        for my $i ($si+1..$fi-1) {
                next if ${$self->{A}}[$i] =~ m/^UID/;
                if (${$self->{A}}[$i] =~ m/^\w+/) {
                        my $contentLine = $self->unfold($i);
                        if ($subComponent ne '') { # we are in a subcomponent
                                $subComponent = '' if $contentLine =~ /^END:$subComponent$/;
                                next;
                        } elsif ($contentLine =~ /^BEGIN:(\w+)$/) { # we have found a subcomponent
                                $subComponent = $1;
                                push @{$e{$subComponent}}, $self->toHash($i, 1);
                        } elsif ($contentLine =~ /^[\w-]+;.*$/s) { # we have params
                                my ($nameAndParamString, @valueFragments) = &parse_line(':', $contentLine);
                                my @values = &parse_line(',', join(':', @valueFragments));
                                my ($name, @params) = &parse_line(';', $nameAndParamString);
                                my %params = map { my ($p, $v) = split(/=/, $_); $p => $v } @params;
                                if (exists $e{$name}) {
                    if (!(@{$e{$name}} && !grep({ref($_) ne 'ARRAY'} @{$e{$name}}))) { # not a strict list of arrays
                        $self->debug("found singleton data, converting to list..");
                        $e{$name} = [$e{$name}, [{%params}, @values]];
                    } else {
                        push @{$e{$name}}, [{%params}, @values];
                    }
                } else {
                    $e{$name} = [{%params}, @values];
                }
                        } elsif ($contentLine =~ /^[\w-]+:.*$/s) { # we don't have params
                                my ($name, @valueFragments) = &parse_line(':', $contentLine);
                                my @values;
                                if ($name eq 'RRULE') {
                                        my @params = &parse_line(';', join(':', @valueFragments));
                                        my %params = map { my ($p, $v) = split(/=/, $_); $p => $v =~ /,/ ? [split(/,/,$v)] : $v } @params;
                                        push @values, {%params};
                                } else {
                                        @values = &parse_line(',', join(':', @valueFragments));
                                }
                                if (exists $e{$name}) {
                    if (!(ref($e{$name}) eq 'ARRAY' && @{$e{$name}} && !grep({ref($_) ne 'ARRAY'} @{$e{$name}}))) { # not a strict list of arrays
                        $self->debug("found singleton data, converting to list..");
                        $e{$name} = [$e{$name}, [@values]];
                    } else {
                        push @{$e{$name}}, [@values];
                    }
                } else {
                                        if (@values == 0) {
                        $e{$name} = "";
                                        } elsif (@values == 1)  {
                                                $e{$name} = $values[0];
                                        } else {
                                                $e{$name} = [@values];
                                        }
                }
                        } else { # what do we have?
                                warn("discovered illegal property format, should be like NAME;...:..., ignoring for now\n");
                        }
                }
        }
         
        return $excludeComponent ?  \%e : [$component, \%e] ;
}
HideShow 30 lines of Pod
=head1 BUGS
Property names are assumed not to be folded, i.e.
        DESCR
         IPTION:blah blah..
      
RRULE property does not support parameters.
Property names that begin with UID can potentially confuse this module.
Subcomponents such as VALARM must exist after any UID property.
Deleting events individually may leave non-RFC2445 compliant empty VCALENDAR objects.
=head1 AUTHOR
Blair Sutton, <mailto:bsdz@cpan.org>, L<http://www.numeninest.com/>
=head1 COPYRIGHT
Copyright (c) 2006 Blair Sutton. All rights reserved.
This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
=head1 SEE ALSO
L<perl>, L<Tie::File>, L<Date::ICal>
=cut
1;