File Coverage

blib/lib/Tie/iCal.pm
Criterion Covered Total %
statement 239 258 92.6
branch 79 98 80.6
condition 9 18 50.0
subroutine 22 23 95.6
pod 0 9 0.0
total 349 406 85.9


line stmt bran cond sub pod time code
1             package Tie::iCal;
2            
3 4     4   60772 use strict;
  4         13  
  4         370  
4             require Exporter;
5             our $VERSION = 0.15;
6             our @ISA = qw(Exporter);
7            
8 4     4   6528 use Tie::File;
  4         101998  
  4         9985  
9            
10             =head1 NAME
11            
12             Tie::iCal - Tie iCal files to Perl hashes.
13            
14             =head1 VERSION
15            
16             This document describes version 0.14 released 1st September 2006.
17            
18             =head1 SYNOPSIS
19            
20             use Tie::iCal;
21            
22             tie %my_events, 'Tie::iCal', "mycalendar.ics" or die "Failed to tie file!\n";
23             tie %your_events, 'Tie::iCal', "yourcalendar.ics" or die "Failed to tie file!\n";
24            
25             $my_events{"A-NEW-UNIQUE-ID"} = [
26             'VEVENT',
27             {
28             'SUMMARY' => 'Bastille Day Party',
29             'DTSTAMP' => '19970714T170000Z',
30             'DTEND' => '19970715T035959Z',
31             }
32             ];
33            
34             tie %our_events, 'Tie::iCal', "ourcalendar.ics" or die "Failed to tie file!\n";
35            
36             # assuming %my_events and %your_events
37             # have no common keys (unless that's your intention)
38             #
39             while (my($uid,$event) = each(%my_events)) {
40             $our_events{$uid} = $event;
41             }
42             while (my($uid,$event) = each(%your_events)) {
43             $our_events{$uid} = $event;
44             }
45            
46             untie %our_events;
47             untie %your_events;
48             untie %my_events;
49            
50             =head1 DEPENDENCIES
51            
52             Tie::File
53            
54             =head1 DESCRIPTION
55            
56             Tie::iCal represents an RFC2445 iCalendar file as a Perl hash. Each key in the hash represents
57             an iCalendar component like VEVENT, VTODO or VJOURNAL. Each component in the file must have
58             a unique UID property as specified in the RFC 2445. A file containing non-unique UIDs can
59             be converted to have only unique UIDs (see samples/uniquify.pl).
60            
61             The module makes very little effort in understanding what each iCalendar property means and concentrates
62             on the format of the iCalendar file only.
63            
64             =head1 FILE LOCKING
65            
66             The Tie::iCal object returned by tie can also be used to access the underlying Tie::File object.
67             This is accessable via the 'A' class variable.
68             This may be useful for file locking.
69            
70             my $ical = tie %events, 'Tie::iCal', "mycalendar.ics";
71             $ical->{A}->flock;
72            
73             =head1 DATES
74            
75             The iCalendar specification uses a special format for dates. This module makes no effort in trying
76             to interpret dates in this format. You should look at the Date::ICal module that can convert between
77             Unix epoch dates and iCalendar date strings.
78            
79             =cut
80            
81             sub TIEHASH {
82 4     4   3687 my ($p, $f, %O) = @_;
83            
84 4 50       39 tie my @a, 'Tie::File', $f, recsep => "\r\n" or die "failed to open ical file\n";
85 4         923 $O{A} = \@a; # file array
86 4         11 $O{i} = 0; # current file index for FIRSTKEY and NEXTKEY
87 4         12 $O{C} = (); # uid to index cache
88            
89 4         34 bless \%O => $p;
90             }
91            
92             sub FETCH {
93 187     187   75885 my $self = shift;
94 187         321 my $uid = shift;
95            
96 187         608 my $index = $self->seekUid($uid);
97            
98 187 50       1009 return defined $index ? $self->toHash($index) : undef;
99             }
100            
101             sub EXISTS {
102 4     4   14113 my $self = shift;
103 4         8 my $uid = shift;
104            
105 4         20 my $index = $self->seekUid($uid);
106            
107 4 100       48 return defined $index ? 1 : 0;
108             }
109            
110             sub FIRSTKEY {
111 4     4   384 my $self = shift;
112            
113 4         23 $self->{i} = 0;
114 4         6 for my $line (@{$self->{A}}) {
  4         28  
115 28 100       11734 if (substr($line, 0, 3) eq 'UID') {
116 4 50       744 if ($self->unfold($self->{i}) =~ /^UID.*:(.*)$/) {
117 4         14 $self->{C}->{$1} = $self->{i}; # cache in any case
118 4         27 return $1;
119             } else {
120 0         0 warn("FIRSTKEY: discovered illegal UID property format, should be like UID;...:..., ignoring for now\n");
121             }
122             }
123 24         4442 $self->{i}++;
124             }
125             }
126            
127             sub NEXTKEY {
128 184     184   45573 my $self = shift;
129            
130             # start search one line after the current point
131 184         404 my $start_idx = ++$self->{i};
132 184         381 for my $line (@{$self->{A}}[$start_idx .. (@{$self->{A}} - 1)]) {
  184         50003  
  184         900  
133 4598 100       12817 if ($line =~ m/^UID/) {
134 180 50       35062 if ($self->unfold($self->{i}) =~ /^UID.*:(.*)$/) {
135 180         749 $self->{C}->{$1} = $self->{i}; # cache in any case
136 180         1225 return $1;
137             } else {
138 0         0 warn("NEXTKEY: discovered illegal UID property format, should be like UID;...:..., ignoring for now\n");
139             }
140             }
141 4418         464016 $self->{i}++;
142             }
143 4         29 return undef;
144             }
145            
146             sub SCALAR {
147 0     0   0 my $self = shift;
148            
149 0         0 my $count = 0;
150 0         0 for my $line (@{$self->{A}}) {
  0         0  
151 0 0       0 $count++ if substr($line, 0, 3) eq 'UID';
152             }
153 0         0 return $count;
154             }
155            
156             sub ceil {
157 813     813 0 2943 return int($_[0]) + (int($_[0]) != $_[0]);
158             }
159            
160             sub fold {
161 48     48 0 141 my $MAXLENGTH = 75;
162 48         116 my @A;
163 48         118 foreach my $string (@_) {
164 813         3486 my @B = unpack("A$MAXLENGTH" x (&ceil(length($string)/$MAXLENGTH)), $string);
165 813         5987 push @A, $B[0], map { ' '.$_ } @B[1..$#B];
  0         0  
166             }
167 48         461 return @A;
168             }
169            
170             sub STORE {
171 48     48   475 my $self = shift;
172 48         104 my $uid = shift;
173 48         102 my $c = shift;
174            
175 48 50       216 die "event must be array!\n" if ref $c ne 'ARRAY';
176            
177 48         166 $self->DELETE($uid);
178            
179 48         84 push @{$self->{A}}, fold($self->toiCal($uid, $c));
  48         271  
180             }
181            
182             sub DELETE {
183 50     50   87 my $self = shift;
184 50         94 my $uid = shift;
185            
186 50         156 my $index = $self->seekUid($uid);
187            
188 50 100       219 return defined $index ? $self->removeComponent($index) : 0;
189             }
190            
191             sub CLEAR {
192 2     2   1172 my $self = shift;
193            
194 2         6 @{$self->{A}} = ();
  2         14  
195             }
196            
197             sub DESTROY {
198 4     4   2434 my $self = shift;
199 4         78 untie $self->{A};
200             }
201            
202             sub debug {
203 5291     5291 0 7616 my $self = shift;
204 5291 50       14957 print(STDERR shift, "\n") if $self->{debug};
205             }
206            
207             sub unfold {
208 4625     4625 0 6688 my $self = shift;
209 4625         6129 my $index = shift;
210            
211 4625         5402 my $result = ${$self->{A}}[$index];
  4625         19001  
212 4625         152940 my $i = 1;
213 4625         6205 until (${$self->{A}}[$index + $i] !~ /^ (.*)$/s) {
  6803         27030  
214 2178         176365 $result .= $1;
215 2178         3255 $i++;
216             }
217 4625         644695 $self->debug("unfolded index $index to $result");
218 4625         24704 return $result;
219             }
220            
221             sub seekUid {
222 241     241 0 381 my $self = shift;
223 241         370 my $uid = shift;
224            
225 241         338 my $index;
226            
227             # check cache
228             #
229 241 100       1043 if (exists $self->{C}->{$uid}) {
230 140         571 $self->debug("found cached index for $uid, checking..");
231 140         379 $index = $self->{C}->{$uid};
232 140 50       354 if ($self->unfold($index) =~ /^UID.*:(.*)$/) {
233 140 100       444 if ($1 eq $uid) {
234 139         518 $self->debug("found key $uid in cache");
235 139         329 return $index;
236             } else {
237 1         8 $self->debug("could not find key $uid in cache, deleting");
238 1         4 delete $self->{C}->{$uid};
239             }
240             } else {
241 0         0 warn("seekUid: discovered illegal UID property format, should be like UID;...:..., ignoring for now\n");
242             }
243             }
244            
245             # not in cache then lets search the file
246             #
247 102         199 $index = 0;
248 102         211 for my $line (@{$self->{A}}) {
  102         693  
249 41599 100       704311 if (substr($line, 0, 3) eq 'UID') {
250 2350 50       481881 if ($self->unfold($index) =~ /^UID.*:(.*)$/) {
251 2350         8950 $self->{C}->{$1} = $index; # cache in any case
252 2350 100       9212 if ($1 eq $uid) {
253 50         191 $self->debug("found key $uid");
254 50         172 return $index;
255             }
256             } else {
257 0         0 warn("discovered illegal UID property format, should be like UID;...:..., ignoring for now\n");
258             }
259             }
260 41549         7971190 $index++;
261             }
262            
263             # doesn't exist!
264             #
265 52         967 return undef;
266             }
267            
268             sub removeComponent {
269 1     1 0 3 my $self = shift;
270 1         2 my $index = shift;
271            
272 1         2 my $i;
273 1         4 $i = 0; $i++ until ${$self->{A}}[$index - $i] =~ /^BEGIN:(\w+)$/; my $si = $index - $i;
  1         2  
  2         42  
  1         174  
274 1         3 my $component = $1;
275 1         2 $i = 0; $i++ until ${$self->{A}}[$index + $i] =~ /^END:$component/; my $fi = $index + $i;
  1         3  
  24         2424  
  1         123  
276 1         9 $self->debug("component $component found between [$si, $fi]");
277            
278 1         2 splice @{$self->{A}}, $si, $fi - $si + 1;
  1         1000  
279             }
280            
281             =head1 How Tie::iCal interprets iCal files
282            
283             Tie::iCal interprets files by mapping iCal components into Perl hash keys and
284             iCal content lines into various Perl arrays and hashes.
285            
286             =head2 Components
287            
288             An iCal component such as VEVENT, VTODO or VJOURNAL maps to a hash key:-
289            
290             BEGIN:VEVENT
291             UID:a_unique_uid
292             NAME1:VALUE1
293             ..
294             END:VEVENT
295            
296             corresponds to
297            
298             $events{'a_unique_uid'} = ['VEVENT', {'NAME1' => 'VALUE1'}]
299            
300             =head2 Subcomponents
301            
302             An iCal subcomponent such as VALARM maps to a list of hash keys:-
303            
304             BEGIN:VALARM
305             TRIGGER;VALUE=DURATION:-PT1S
306             TRIGGER;VALUE=DURATION:-PT1S
307             END:VALARM
308             BEGIN:VALARM
309             X-TIE-ICAL;VALUE=ANOTHER:HERE
310             X-TIE-ICAL:HERE2
311             X-TIE-ICAL-NAME:HERE2
312             END:VALARM
313            
314             corresponds to
315            
316             'VALARM' => [
317             {
318             'TRIGGER' => [
319             [{'VALUE' => 'DURATION'},'-PT1S'],
320             [{'VALUE' => 'DURATION'},'-PT1S']
321             ]
322             },
323             {
324             'X-TIE-ICAL' => [
325             [{'VALUE' => 'ANOTHER'},'HERE'],
326             ['HERE2']
327             ],
328             'X-TIE-ICAL-NAME' => 'HERE2'
329             }
330             ]
331            
332             To see how individual content lines are formed see below.
333            
334             =head2 Content Lines
335            
336             Once unfolded, a content line may look like:-
337            
338             NAME;PARAM1=PVAL1;PARAM2=PVAL2;...:VALUE1,VALUE2,...
339            
340             having an equivalent perl data structure like: -
341            
342             'NAME' => [{'PARAM1'=>'PVAL1', 'PARAM2'=>'PVAL2', ..}, 'VALUE1', 'VALUE2', ..]
343            
344             or
345            
346             NAME:VALUE1,VALUE2,...
347            
348             having an equivalent perl data structure like: -
349            
350             'NAME' => ['VALUE1', 'VALUE2', ..]
351            
352             or
353            
354             NAME:VALUE
355            
356             having an equivalent perl data structure like: -
357            
358             'NAME' => 'VALUE'
359            
360             An blank value is mapped from
361            
362             NAME:
363            
364             to
365            
366             'NAME' => ''
367            
368             Multiple contentlines with same name, i.e. FREEBUSY, ATTENDEE:-
369            
370             NAME;PARAM10=PVAL10;PARAM20=PVAL20;...:VALUE10,VALUE20,...
371             NAME;PARAM11=PVAL11;PARAM21=PVAL21;...:VALUE11,VALUE21,...
372             ...
373            
374             having an equivalent perl data structure like: -
375            
376             'NAME' => [
377             [{'PARAM10'=>'PVAL10', 'PARAM20'=>'PVAL20', ..}, 'VALUE10', 'VALUE20', ..],
378             [{'PARAM11'=>'PVAL11', 'PARAM21'=>'PVAL21', ..}, 'VALUE11', 'VALUE21', ..],
379             ...
380             ]
381            
382             or
383            
384             NAME:VALUE10,VALUE20,...
385             NAME:VALUE11,VALUE21,...
386             ...
387            
388             having an equivalent perl data structure like: -
389            
390             'NAME' => [
391             ['VALUE10', 'VALUE20', ..],
392             ['VALUE11', 'VALUE21', ..],
393             ...
394             ]
395            
396             or in a mixed form, i.e.
397            
398             NAME:VALUE10,VALUE20,...
399             NAME;PARAM11=PVAL11;PARAM21=PVAL21:VALUE11,VALUE21,...
400             NAME:VALUE12,VALUE22,...
401             ...
402            
403             having an equivalent perl data structure like: -
404            
405             'NAME' => [
406             ['VALUE10', 'VALUE20', ..],
407             [{'PARAM11'=>'PVAL11', 'PARAM21'=>'PVAL21', ..}, 'VALUE11', 'VALUE21', ..],
408             ['VALUE12', 'VALUE22', ..],
409             ...
410             ]
411            
412             =cut
413            
414             sub toiCal {
415 84     84 0 161 my $self = shift;
416 84         141 my $uid = shift;
417 84         203 my $c = shift;
418 84         135 my $excludeComponent = shift;
419            
420 84         122 my @lines;
421 84 100       290 my ($component, $e) = $excludeComponent ? (undef, $c) : @$c;
422 84 100       1187 push @lines, "BEGIN:VCALENDAR", "VERSION:2.0", "PRODID:-//Numen Inest/NONSGML Tie::iCal $VERSION//EN", "BEGIN:$component", "UID:$uid" if ! $excludeComponent;
423 84         603 foreach my $name (keys %$e) {
424 430 100       1637 if ($name eq 'RRULE') {
    100          
    50          
425 3 50       15 if (ref($$e{$name}) ne 'HASH') {
426 0         0 warn "RRULE property should be expressed as a hash, ignoring..\n";
427             } else {
428 3         8 my @rrule;
429 3         6 foreach my $k (keys %{$$e{$name}}) {
  3         14  
430 9 100       13 push @rrule, ref(${$$e{$name}}{$k}) eq 'ARRAY' ? "$k=".join(',', @{${$$e{$name}}{$k}}) : "$k=".${$$e{$name}}{$k};
  9         65  
  3         5  
  3         15  
  6         22  
431             }
432 3         19 push @lines, "$name:".join(';',@rrule);
433             }
434             } elsif (ref(\$$e{$name}) eq 'SCALAR') {
435 272         809 push @lines, "$name:$$e{$name}";
436             } elsif (ref($$e{$name}) eq 'ARRAY') {
437 155 100 66     206 if (@{$$e{$name}} && !grep({ref($_) ne 'HASH'} @{$$e{$name}})) { # strict list of hashes => we have a subcomponent
  155 100 66     556  
  281         1090  
  155         374  
  119         406  
438 36         91 push @lines, "BEGIN:$name";
439 36         58 foreach my $sc (@{$$e{$name}}) {
  36         115  
440 36         174 push @lines, $self->toiCal(undef, $sc, 1);
441             }
442 36         118 push @lines, "END:$name";
443 245         760 } elsif (@{$$e{$name}} && !grep({ref($_) ne 'ARRAY'} @{$$e{$name}})) { # strict list of arrays => we have several content lines
  119         229  
444 4         7 foreach my $cl (@{$$e{$name}}) {
  4         12  
445 15 100       18 if (ref(${$cl}[0]) eq 'HASH') { # we have params
  15         41  
446 12         12 my ($params, @values) = @{$cl};
  12         33  
447 12         42 push @lines, "$name;".join(";", map { "$_=$$params{$_}" } keys(%$params)).":".join(',',@values);
  30         123  
448             } else { # we only have values
449 3         8 push @lines, "$name:".join(',',@{$cl});
  3         14  
450             }
451             }
452             } else {
453 115         157 my ($params, @values) = @{$$e{$name}};
  115         339  
454 115         425 push @lines, "$name;".join(";", map { "$_=$$params{$_}" } keys(%$params)).":".join(',',@values);
  115         831  
455             }
456             } else {
457 0         0 warn "ignoring unimplemented ",ref(\${$e}{$name})," -> ",$name."\n";
  0         0  
458             }
459             }
460 84 100       347 push @lines, "END:$component", "END:VCALENDAR" if ! $excludeComponent;
461            
462 84         588 return @lines;
463             }
464            
465             # taken from Text::ParseWords without single quote as quote char
466             # and keep flag
467             #
468             sub parse_line {
469             # We will be testing undef strings
470 4     4   55 no warnings;
  4         13  
  4         216  
471 4     4   23 use re 'taint'; # if it's tainted, leave it as such
  4         14  
  4         13966  
472            
473 3547     3547 0 6125 my($delimiter, $line) = @_;
474 3547         4318 my($word, @pieces);
475            
476 3547         7143 while (length($line)) {
477 5654 50       296175 $line =~ s/^(["]) # a $quote
478             ((?:\\.|(?!\1)[^\\])*) # and $quoted text
479             \1 # followed by the same quote
480             | # --OR--
481             ^((?:\\.|[^\\"])*?) # an $unquoted text
482             (\Z(?!\n)|(?-x:$delimiter)|(?!^)(?=["]))
483             # plus EOL, delimiter, or quote
484             //xs or return; # extended layout
485 5654         29572 my($quote, $quoted, $unquoted, $delim) = ($1, $2, $3, $4);
486 5654 50 33     28009 return() unless( defined($quote) || length($unquoted) || length($delim));
      33        
487            
488 5654         9924 $quoted = "$quote$quoted$quote";
489 5654 50       11356 $word .= defined $quote ? $quoted : $unquoted;
490            
491 5654 100       11400 if (length($delim)) {
492 2107         3551 push(@pieces, $word);
493 2107         3138 undef $word;
494             }
495 5654 100       14397 if (!length($line)) {
496 3547         13357 push(@pieces, $word);
497             }
498             }
499 3547         12602 return(@pieces);
500             }
501            
502             sub toHash {
503 326     326 0 511 my $self = shift;
504 326         578 my $index = shift;
505 326         462 my $excludeComponent = shift;
506            
507 326         481 my $i;
508 326         546 $i = 0; $i++ until ${$self->{A}}[$index - $i] =~ /^BEGIN:(\w+)$/; my $si = $index - $i;
  326         622  
  549         9414  
  326         12037  
509 326         812 my $component = $1;
510 326         443 $i = 0; $i++ until ${$self->{A}}[$index + $i] =~ /^END:$component/; my $fi = $index + $i;
  326         451  
  4337         525094  
  326         33104  
511 326         1798 $self->debug("component $component found between [$si, $fi]");
512            
513 326         563 my %e;
514 326         517 my $subComponent = '';
515 326         1346 for my $i ($si+1..$fi-1) {
516 3908 100       62762 next if ${$self->{A}}[$i] =~ m/^UID/;
  3908         22249  
517 3721 100       144777 if (${$self->{A}}[$i] =~ m/^\w+/) {
  3721         13908  
518 1951         72646 my $contentLine = $self->unfold($i);
519 1951 100       15019 if ($subComponent ne '') { # we are in a subcomponent
    100          
    100          
    50          
520 281 100       1571 $subComponent = '' if $contentLine =~ /^END:$subComponent$/;
521 281         805 next;
522             } elsif ($contentLine =~ /^BEGIN:(\w+)$/) { # we have found a subcomponent
523 139         325 $subComponent = $1;
524 139         193 push @{$e{$subComponent}}, $self->toHash($i, 1);
  139         920  
525             } elsif ($contentLine =~ /^[\w-]+;.*$/s) { # we have params
526 485         1024 my ($nameAndParamString, @valueFragments) = &parse_line(':', $contentLine);
527 485         1603 my @values = &parse_line(',', join(':', @valueFragments));
528 485         1116 my ($name, @params) = &parse_line(';', $nameAndParamString);
529 485         977 my %params = map { my ($p, $v) = split(/=/, $_); $p => $v } @params;
  533         1853  
  533         2430  
530 485 100       1187 if (exists $e{$name}) {
531 25 100 66     33 if (!(@{$e{$name}} && !grep({ref($_) ne 'ARRAY'} @{$e{$name}}))) { # not a strict list of arrays
532 9         26 $self->debug("found singleton data, converting to list..");
533 9         87 $e{$name} = [$e{$name}, [{%params}, @values]];
534             } else {
535 16         22 push @{$e{$name}}, [{%params}, @values];
  16         143  
536             }
537             } else {
538 460         4152 $e{$name} = [{%params}, @values];
539             }
540             } elsif ($contentLine =~ /^[\w-]+:.*$/s) { # we don't have params
541 1046         2239 my ($name, @valueFragments) = &parse_line(':', $contentLine);
542 1046         1578 my @values;
543 1046 100       2362 if ($name eq 'RRULE') {
544 7         30 my @params = &parse_line(';', join(':', @valueFragments));
545 7 100       19 my %params = map { my ($p, $v) = split(/=/, $_); $p => $v =~ /,/ ? [split(/,/,$v)] : $v } @params;
  21         65  
  21         131  
546 7         43 push @values, {%params};
547             } else {
548 1039         3246 @values = &parse_line(',', join(':', @valueFragments));
549             }
550 1046 100       2660 if (exists $e{$name}) {
551 6 50 33     33 if (!(ref($e{$name}) eq 'ARRAY' && @{$e{$name}} && !grep({ref($_) ne 'ARRAY'} @{$e{$name}}))) { # not a strict list of arrays
552 0         0 $self->debug("found singleton data, converting to list..");
553 0         0 $e{$name} = [$e{$name}, [@values]];
554             } else {
555 6         10 push @{$e{$name}}, [@values];
  6         32  
556             }
557             } else {
558 1040 50       2983 if (@values == 0) {
    50          
559 0         0 $e{$name} = "";
560             } elsif (@values == 1) {
561 1040         5127 $e{$name} = $values[0];
562             } else {
563 0         0 $e{$name} = [@values];
564             }
565             }
566             } else { # what do we have?
567 0         0 warn("discovered illegal property format, should be like NAME;...:..., ignoring for now\n");
568             }
569             }
570             }
571            
572 326 100       6993 return $excludeComponent ? \%e : [$component, \%e] ;
573             }
574            
575             =head1 BUGS
576            
577             Property names are assumed not to be folded, i.e.
578            
579             DESCR
580             IPTION:blah blah..
581            
582             RRULE property does not support parameters.
583            
584             Property names that begin with UID can potentially confuse this module.
585            
586             Subcomponents such as VALARM must exist after any UID property.
587            
588             Deleting events individually may leave non-RFC2445 compliant empty VCALENDAR objects.
589            
590             =head1 AUTHOR
591            
592             Blair Sutton, , L
593            
594             =head1 COPYRIGHT
595            
596             Copyright (c) 2006 Blair Sutton. All rights reserved.
597             This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
598            
599             =head1 SEE ALSO
600            
601             L, L, L
602            
603             =cut
604            
605             1;