File Coverage

blib/lib/Data/ICal/Property.pm
Criterion Covered Total %
statement 87 89 97.7
branch 24 28 85.7
condition 8 10 80.0
subroutine 14 14 100.0
pod 5 5 100.0
total 138 146 94.5


line stmt bran cond sub pod time code
1 13     13   92 use warnings;
  13         27  
  13         446  
2 13     13   71 use strict;
  13         24  
  13         442  
3              
4             package Data::ICal::Property;
5              
6 13     13   65 use base qw/Class::Accessor/;
  13         24  
  13         1511  
7              
8 13     13   150 use Carp;
  13         26  
  13         765  
9 13     13   5941 use MIME::QuotedPrint ();
  13         17853  
  13         15894  
10              
11             our $VERSION = '0.06';
12              
13             =head1 NAME
14              
15             Data::ICal::Property - Represents a property on an entry in an iCalendar file
16              
17             =head1 DESCRIPTION
18              
19             A L object represents a single property on an
20             entry in an iCalendar file. Properties have parameters in addition to
21             their value.
22              
23             You shouldn't need to create L values directly
24             -- just use C in L.
25              
26             The C parameter value is only interpreted by L
27             in the C and C methods: all other methods
28             access the encoded version directly (if there is an encoding).
29              
30             Currently, the only supported encoding is C.
31              
32             =head1 METHODS
33              
34             =cut
35              
36             =head2 new $key, $value, [$parameter_hash]
37              
38             Creates a new L with key C<$key> and value C<$value>.
39              
40             If C<$parameter_hash> is provided, sets the property's parameters to
41             it. The parameter hash should have keys equal to the names of the
42             parameters (case insensitive; parameter hashes should not contain two
43             different keys which are the same when converted to upper case); the
44             values should either be a string if the parameter has a single value
45             or an array reference of strings if the parameter has multiple values.
46              
47             =cut
48              
49             sub new {
50 362     362 1 575 my $class = shift;
51 362         568 my $self = {};
52              
53 362         610 bless $self, $class;
54              
55 362         890 $self->key(shift);
56 362         4297 $self->value(shift);
57 362   50     3808 $self->parameters( shift || {} );
58 362         3308 return ($self);
59             }
60              
61             =head2 key [$key]
62              
63             Gets or sets the key name of this property.
64              
65             =head2 value [$value]
66              
67             Gets or sets the value of this property.
68              
69             =head2 parameters [$param_hash]
70              
71             Gets or sets the parameter hash reference of this property. Parameter
72             keys are converted to upper case.
73              
74             =head2 vcal10 [$bool]
75              
76             Gets or sets a boolean saying whether this should be interpreted as
77             vCalendar 1.0 (as opposed to iCalendar 2.0). Generally, you can just
78             set this on your main L object when you construct it;
79             C automatically makes sure that sub-entries end up with the
80             same value as their parents, and C makes sure that
81             properties end up with the same value as their entry.
82              
83             =cut
84              
85             __PACKAGE__->mk_accessors(qw(key value _parameters vcal10));
86              
87             sub parameters {
88 651     651 1 1308 my $self = shift;
89              
90 651 100       1317 if (@_) {
91 362         543 my $params = shift;
92 362         554 my $new_params = {};
93 362         1122 while ( my ( $k, $v ) = each %$params ) {
94 41         182 $new_params->{ uc $k } = $v;
95             }
96 362         745 $self->_parameters($new_params);
97             }
98              
99 651         4028 return $self->_parameters;
100             }
101              
102             my %ENCODINGS = (
103             'QUOTED-PRINTABLE' => {
104             encode => sub {
105             my $dec = shift || '';
106             $dec =~ s/\n/\r\n/g;
107             return MIME::QuotedPrint::encode( $dec, '' );
108             },
109             decode => sub {
110             my $dec = MIME::QuotedPrint::decode( shift || '' );
111             $dec =~ s/\r\n/\n/g;
112             return $dec;
113             }
114             },
115             );
116              
117             =head2 decoded_value
118              
119             Gets the value of this property, converted from the encoding specified
120             in its encoding parameter. (That is, C will return the encoded
121             version; this will apply the encoding.) If the encoding is not
122             specified or recognized, just returns the raw value.
123              
124             =cut
125              
126             sub decoded_value {
127 4     4 1 8 my $self = shift;
128 4         10 my $value = $self->value;
129 4   100     41 my $encoding = uc( $self->parameters->{'ENCODING'} || "" );
130              
131 4 100       58 if ( $ENCODINGS{$encoding} ) {
132 2         8 return $ENCODINGS{$encoding}{'decode'}->($value);
133             } else {
134 2         6 return $value;
135             }
136             }
137              
138             =head2 encode $encoding
139              
140             Calls C to get the current decoded value, then encodes
141             it in C<$encoding>, sets the value to that, and sets the encoding
142             parameter to C<$encoding>. (C<$encoding> is first converted to upper
143             case.)
144              
145             If C<$encoding> is undef, deletes the encoding parameter and sets the
146             value to the decoded value. Does nothing if the encoding is not
147             recognized.
148              
149             =cut
150              
151             sub encode {
152 2     2 1 5 my $self = shift;
153 2         6 my $encoding = uc shift;
154              
155 2         6 my $decoded_value = $self->decoded_value;
156              
157 2 50       11 if ( not defined $encoding ) {
    50          
158 0         0 $self->value($decoded_value);
159 0         0 delete $self->parameters->{'ENCODING'};
160             } elsif ( $ENCODINGS{$encoding} ) {
161 2         8 $self->value( $ENCODINGS{$encoding}{'encode'}->($decoded_value) );
162 2         27 $self->parameters->{'ENCODING'} = $encoding;
163             }
164 2         22 return $self;
165             }
166              
167             =head2 as_string ARGS
168              
169             Returns the property formatted as a string (including trailing
170             newline).
171              
172             Takes named arguments:
173              
174             =over
175              
176             =item fold
177              
178             Defaults to true. pass in a false value if you need to generate
179             non-rfc-compliant calendars.
180              
181             =item crlf
182              
183             Defaults to C<\x0d\x0a>, per RFC 2445 spec. This option is primarily
184             for backwards compatibility with version of this module prior to 0.16,
185             which used C<\x0a>.
186              
187             =back
188              
189             =cut
190              
191             sub as_string {
192 204     204 1 296 my $self = shift;
193 204         668 my %args = (
194             fold => 1,
195             crlf => Data::ICal::Entry->CRLF,
196             @_
197             );
198             my $string
199             = uc( $self->key )
200             . $self->_parameters_as_string . ":"
201             . $self->_value_as_string( $self->key )
202 204         427 . $args{crlf};
203              
204             # Assumption: the only place in an iCalendar that needs folding are property
205             # lines
206 204 100       474 if ( $args{'fold'} ) {
207 202         406 return $self->_fold( $string, $args{crlf} );
208             }
209              
210 2         10 return $string;
211             }
212              
213             =begin private
214              
215             =head2 _value_as_string
216              
217             Returns the property's value as a string. Comma and semicolon are not
218             escaped when the value is recur type (the key is rrule).
219              
220             Values are quoted according the iCal spec, unless this is in vCal 1.0
221             mode.
222              
223             =end private
224              
225             =cut
226              
227             sub _value_as_string {
228 204     204   1899 my $self = shift;
229 204         279 my $key = shift;
230 204 50       371 my $value = defined( $self->value() ) ? $self->value() : '';
231              
232 204 100       3595 unless ( $self->vcal10 ) {
233 151         1446 $value =~ s/\\/\\\\/gs;
234 151 100 66     605 $value =~ s/;/\\;/gs unless lc($key) eq 'rrule' || lc($key) eq 'geo';
235 151 50       331 $value =~ s/,/\\,/gs unless lc($key) eq 'rrule';
236 151         214 $value =~ s/\x0d?\x0a/\\n/gs;
237             }
238              
239 204         929 return $value;
240             }
241              
242             =begin private
243              
244             =head2 _parameters_as_string
245              
246             Returns the property's parameters as a string. Properties are sorted alphabetically
247             to aid testing.
248              
249             =end private
250              
251             =cut
252              
253             sub _parameters_as_string {
254 204     204   1993 my $self = shift;
255 204         289 my $out = '';
256 204         263 for my $name ( sort keys %{ $self->parameters } ) {
  204         329  
257 23         244 my $value = $self->parameters->{$name};
258 23 100       279 $out
259             .= ';'
260             . $name . '='
261             . $self->_quoted_parameter_values(
262             ref $value ? @$value : $value );
263             }
264 204         2142 return $out;
265             }
266              
267             =begin private
268              
269             =head2 _quoted_parameter_values @values
270              
271             Quotes any of the values in C<@values> that need to be quoted and
272             returns the quoted values joined by commas.
273              
274             If any of the values contains a double-quote, erases it and emits a
275             warning.
276              
277             =end private
278              
279             =cut
280              
281             sub _quoted_parameter_values {
282 23     23   67 my $self = shift;
283 23         54 my @values = @_;
284              
285 23         49 for my $val (@values) {
286 25 100       87 if ( $val =~ /"/ ) {
287              
288             # Get all the way back to the user's code
289 1         3 local $Carp::CarpLevel = $Carp::CarpLevel + 1;
290 1         19 carp "Invalid parameter value (contains double quote): $val";
291 1         907 $val =~ tr/"//d;
292             }
293             }
294              
295 23 100       46 return join ',', map { /[;,:]/ ? qq("$_") : $_ } @values;
  25         161  
296             }
297              
298             =begin private
299              
300             =head2 _fold $string $crlf
301              
302             Returns C<$string> folded with newlines and leading whitespace so that
303             each line is at most 75 characters.
304              
305             (Note that it folds at 75 characters, not 75 bytes as specified in the
306             standard.)
307              
308             If this is vCalendar 1.0 and encoded with QUOTED-PRINTABLE, does not
309             fold at all.
310              
311             =end private
312              
313             =cut
314              
315             sub _fold {
316 202     202   301 my $self = shift;
317 202         272 my $string = shift;
318 202         259 my $crlf = shift;
319              
320             my $quoted_printable = $self->vcal10
321 202   100     386 && uc( $self->parameters->{'ENCODING'} || '' ) eq 'QUOTED-PRINTABLE';
322              
323 202 100       2041 if ($quoted_printable) {
324              
325             # In old vcal, quoted-printable properties have different folding rules.
326             # But some interop tests suggest it's wiser just to not fold for vcal 1.0
327             # at all (in quoted-printable).
328             } else {
329 199 100       1038 return $string unless length $string > 75;
330              
331 16         146 $string =~ s{$crlf\z}{};
332              
333 16         65 my $out = substr($string, 0, 75, "") . $crlf;
334              
335 16         41 while (length $string) {
336 25         49 my $substr = substr $string, 0, 74, "";
337 25         74 $out .= " $substr$crlf";
338             }
339              
340 16         98 return $out;
341             }
342              
343 3         18 return $string;
344             }
345              
346             =head1 AUTHOR
347              
348             Best Practical Solutions, LLC Emodules@bestpractical.comE
349              
350             =head1 LICENCE AND COPYRIGHT
351              
352             Copyright (c) 2005 - 2020, Best Practical Solutions, LLC. All rights reserved.
353              
354             This module is free software; you can redistribute it and/or
355             modify it under the same terms as Perl itself. See L.
356              
357             =cut
358              
359             1;
360