~ubuntu-branches/ubuntu/lucid/libdata-ical-perl/lucid

« back to all changes in this revision

Viewing changes to lib/Data/ICal/Property.pm

  • Committer: Bazaar Package Importer
  • Author(s): Peter Makholm
  • Date: 2007-12-04 07:39:22 UTC
  • Revision ID: james.westby@ubuntu.com-20071204073922-mosdr2aj4ks656xz
Tags: upstream-0.13+dfsg
ImportĀ upstreamĀ versionĀ 0.13+dfsg

Show diffs side-by-side

added added

removed removed

Lines of Context:
 
1
use warnings;
 
2
use strict;
 
3
 
 
4
package Data::ICal::Property;
 
5
 
 
6
use base qw/Class::Accessor/;
 
7
 
 
8
use Carp;
 
9
use MIME::QuotedPrint ();
 
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
  
 
18
=head1 DESCRIPTION
 
19
 
 
20
A L<Data::ICal::Property> object represents a single property on an
 
21
entry in an iCalendar file.  Properties have parameters in addition to their value.
 
22
 
 
23
You shouldn't need to create L<Data::ICal::Property> values directly -- just use
 
24
C<add_property> in L<Data::ICal::Entry>.
 
25
 
 
26
The C<encoding> parameter value is only interpreted by L<Data::ICal> in the
 
27
C<decoded_value> and C<encode> methods: all other methods access
 
28
the encoded version directly (if there is an encoding).
 
29
 
 
30
Currently, the only supported encoding is C<QUOTED-PRINTABLE>.
 
31
 
 
32
=head1 METHODS
 
33
 
 
34
=cut
 
35
 
 
36
=head2 new $key, $value, [$parameter_hash]
 
37
 
 
38
Creates a new L<Data::ICal::Property> with key C<$key> and value C<$value>.
 
39
 
 
40
If C<$parameter_hash> is provided, sets the property's parameters to it.
 
41
The parameter hash should have keys equal to the names of the parameters (case 
 
42
insensitive; parameter hashes should not contain two different keys which are
 
43
the same when converted to upper case); the values should either be a string
 
44
if the parameter has a single value or an array reference of strings if
 
45
the parameter has multiple values.
 
46
 
 
47
=cut
 
48
 
 
49
sub new {
 
50
    my $class = shift;
 
51
    my $self  = {};
 
52
 
 
53
    bless $self, $class;
 
54
 
 
55
    $self->key(shift);
 
56
    $self->value(shift);
 
57
    $self->parameters( shift || {} );
 
58
    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.
 
72
Parameter 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 vCalendar
 
77
1.0 (as opposed to iCalendar 2.0).  Generally, you can just set this on your
 
78
main L<Data::ICal> object when you construct it; C<add_entry> automatically makes
 
79
sure that sub-entries end up with the same value as their parents, and 
 
80
C<add_property> makes sure that properties end up with the same value as
 
81
their entry.
 
82
 
 
83
=cut
 
84
 
 
85
__PACKAGE__->mk_accessors(qw(key value _parameters vcal10));
 
86
 
 
87
sub parameters {
 
88
    my $self = shift;
 
89
    
 
90
    if (@_) {
 
91
        my $params = shift;
 
92
        my $new_params = {};
 
93
        while (my ($k, $v) = each %$params) {
 
94
            $new_params->{uc $k} = $v;
 
95
        } 
 
96
        $self->_parameters($new_params);
 
97
    } 
 
98
 
 
99
    return $self->_parameters;
 
100
 
101
 
 
102
my %ENCODINGS = (
 
103
    'QUOTED-PRINTABLE' => { encode => sub { 
 
104
                                my $dec = shift ||'';
 
105
                                $dec =~ s/\n/\r\n/g;
 
106
                                return MIME::QuotedPrint::encode($dec, '');
 
107
                            },
 
108
                            decode => sub {
 
109
                                my $dec = MIME::QuotedPrint::decode(shift ||'');
 
110
                                $dec =~ s/\r\n/\n/g;
 
111
                                return $dec;
 
112
                            }
 
113
                        },
 
114
); 
 
115
 
 
116
=head2 decoded_value
 
117
 
 
118
Gets the value of this property, converted from the encoding specified in 
 
119
its encoding parameter.  (That is, C<value> will return the encoded version;
 
120
this will apply the encoding.)  If the encoding is not specified or recognized, just returns
 
121
the raw value.
 
122
 
 
123
=cut
 
124
 
 
125
sub decoded_value {
 
126
    my $self = shift;
 
127
    my $value = $self->value;
 
128
    my $encoding = uc $self->parameters->{'ENCODING'};
 
129
 
 
130
    if ($ENCODINGS{$encoding}) {
 
131
        return $ENCODINGS{$encoding}{'decode'}->($value);
 
132
    } else {
 
133
        return $value;
 
134
    } 
 
135
 
136
 
 
137
=head2 encode $encoding
 
138
 
 
139
Calls C<decoded_value> to get the current decoded value, then encodes it in C<$encoding>,
 
140
sets the value to that, and sets the encoding parameter to C<$encoding>. (C<$encoding> is
 
141
first converted to upper case.)
 
142
 
 
143
If C<$encoding> is undef, deletes the encoding parameter and sets the value to the decoded
 
144
value.  Does nothing if the encoding is not recognized.
 
145
 
 
146
=cut
 
147
 
 
148
sub encode {
 
149
    my $self = shift;
 
150
    my $encoding = uc shift;
 
151
 
 
152
    my $decoded_value = $self->decoded_value;
 
153
 
 
154
    if (not defined $encoding) {
 
155
        $self->value($decoded_value);
 
156
        delete $self->parameters->{'ENCODING'};
 
157
    } elsif ($ENCODINGS{$encoding}) {
 
158
        $self->value( $ENCODINGS{$encoding}{'encode'}->($decoded_value) );
 
159
        $self->parameters->{'ENCODING'} = $encoding;
 
160
    } 
 
161
 
162
 
 
163
=head2 as_string ARGS
 
164
 
 
165
Returns the property formatted as a string (including trailing newline).
 
166
 
 
167
Takes named arguments:
 
168
 
 
169
=over
 
170
 
 
171
=item fold
 
172
 
 
173
Defaults to true. pass in a false value if you need to generate non-rfc-compliant calendars.
 
174
 
 
175
=back
 
176
 
 
177
 
 
178
=cut
 
179
 
 
180
sub as_string {
 
181
    my $self   = shift;
 
182
    my %args   = ( fold => 1, @_ );
 
183
    my $string = uc( $self->key )
 
184
        . $self->_parameters_as_string . ":"
 
185
        . $self->_value_as_string( $self->key ) . "\n";
 
186
 
 
187
  # Assumption: the only place in an iCalendar that needs folding are property
 
188
  # lines
 
189
    if ( $args{'fold'} ) {
 
190
        return $self->_fold($string);
 
191
    } else {
 
192
        return $string;
 
193
    }
 
194
}
 
195
 
 
196
=begin private
 
197
 
 
198
=head2 _value_as_string
 
199
 
 
200
Returns the property's value as a string.  
 
201
Comma and semicolon are not escaped when the value is recur type (the key is 
 
202
rrule).
 
203
 
 
204
Values are quoted according the iCal spec, unless 
 
205
this is in vCal 1.0 mode.
 
206
 
 
207
=end private
 
208
 
 
209
=cut
 
210
 
 
211
sub _value_as_string {
 
212
    my $self = shift;
 
213
    my $key = shift;
 
214
    my $value = defined($self->value()) ? $self->value() : '';
 
215
    
 
216
    unless ($self->vcal10) {
 
217
        $value =~ s/\\/\\/gs;
 
218
        $value =~ s/\Q;/\\;/gs unless lc($key) eq 'rrule';
 
219
        $value =~ s/,/\\,/gs unless lc($key) eq 'rrule';
 
220
        $value =~ s/\n/\\n/gs;
 
221
        $value =~ s/\\N/\\N/gs;
 
222
    }
 
223
 
 
224
    return $value;
 
225
 
 
226
}
 
227
 
 
228
=begin private
 
229
 
 
230
=head2 _parameters_as_string
 
231
 
 
232
Returns the property's parameters as a string.  Properties are sorted alphabetically
 
233
to aid testing.
 
234
 
 
235
=end private
 
236
 
 
237
=cut
 
238
 
 
239
sub _parameters_as_string {
 
240
    my $self = shift;
 
241
    my $out  = '';
 
242
    for my $name ( sort keys %{ $self->parameters } ) {
 
243
        my $value = $self->parameters->{$name};
 
244
        $out .= ';'
 
245
            . $name . '='
 
246
            . $self->_quoted_parameter_values(
 
247
            ref $value ? @$value : $value );
 
248
    }
 
249
    return $out;
 
250
}
 
251
 
 
252
=begin private
 
253
 
 
254
=head2 _quoted_parameter_values @values
 
255
 
 
256
Quotes any of the values in C<@values> that need to be quoted and returns the quoted values
 
257
joined by commas.
 
258
 
 
259
If any of the values contains a double-quote, erases it and emits a warning.
 
260
 
 
261
=end private
 
262
 
 
263
=cut
 
264
 
 
265
sub _quoted_parameter_values {
 
266
    my $self   = shift;
 
267
    my @values = @_;
 
268
 
 
269
    for my $val (@values) {
 
270
        if ( $val =~ /"/ ) {
 
271
 
 
272
            # Get all the way back to the user's code
 
273
            local $Carp::CarpLevel = $Carp::CarpLevel + 1;
 
274
            carp "Invalid parameter value (contains double quote): $val";
 
275
            $val =~ tr/"//d;
 
276
        }
 
277
    }
 
278
 
 
279
    return join ',', map { /[;,:]/ ? qq("$_") : $_ } @values;
 
280
}
 
281
 
 
282
=begin private
 
283
 
 
284
=head2 _fold $string
 
285
 
 
286
Returns C<$string> folded with newlines and leading whitespace so that each
 
287
line is at most 75 characters.
 
288
 
 
289
(Note that it folds at 75 characters, not 75 bytes as specified in the standard.)
 
290
 
 
291
If this is vCalendar 1.0 and encoded with QUOTED-PRINTABLE, folds with = instead.
 
292
 
 
293
=end private
 
294
 
 
295
=cut
 
296
 
 
297
sub _fold {
 
298
    my $self   = shift;
 
299
    my $string = shift;
 
300
 
 
301
    my $quoted_printable = $self->vcal10 && 
 
302
        uc $self->parameters->{'ENCODING'} eq 'QUOTED-PRINTABLE';
 
303
 
 
304
    # We can't just use a s//g, because we need to include the added space/= and
 
305
    # first character of the next line in the count for the next line.
 
306
 
 
307
    if ($quoted_printable) {
 
308
        # In old vcal, quoted-printable properties have different folding rules.
 
309
        # But some interop tests suggest it's wiser just to not fold for vcal 1.0
 
310
        # at all (in quoted-printable).
 
311
 
 
312
        # [do nothing]
 
313
 
 
314
#        while ( $string =~ /.{75}[^\n=]/ ) {
 
315
#            $string =~ s/(.{75})([^\n=])/$1=\n$2/;
 
316
#        }
 
317
    } else {
 
318
        while ( $string =~ /(.{76})/ ) {
 
319
            $string =~ s/(.{75})(.)/$1\n $2/;
 
320
        }
 
321
    }
 
322
 
 
323
    return $string;
 
324
}
 
325
 
 
326
1;
 
327