use warnings;
use strict;

package Data::ICal::Property;

use base qw/Class::Accessor/;

use Carp;
use MIME::QuotedPrint ();

our $VERSION = '0.06';

=head1 NAME

Data::ICal::Property - Represents a property on an entry in an iCalendar file

=head1 DESCRIPTION

A L<Data::ICal::Property> object represents a single property on an
entry in an iCalendar file.  Properties have parameters in addition to
their value.

You shouldn't need to create L<Data::ICal::Property> values directly
-- just use C<add_property> in L<Data::ICal::Entry>.

The C<encoding> parameter value is only interpreted by L<Data::ICal>
in the C<decoded_value> and C<encode> methods: all other methods
access the encoded version directly (if there is an encoding).

Currently, the only supported encoding is C<QUOTED-PRINTABLE>.

=head1 METHODS

=cut

=head2 new $key, $value, [$parameter_hash]

Creates a new L<Data::ICal::Property> with key C<$key> and value C<$value>.

If C<$parameter_hash> is provided, sets the property's parameters to
it.  The parameter hash should have keys equal to the names of the
parameters (case insensitive; parameter hashes should not contain two
different keys which are the same when converted to upper case); the
values should either be a string if the parameter has a single value
or an array reference of strings if the parameter has multiple values.

=cut

sub new {
    my $class = shift;
    my $self  = {};

    bless $self, $class;

    $self->key(shift);
    $self->value(shift);
    $self->parameters( shift || {} );
    return ($self);
}

=head2 key [$key]

Gets or sets the key name of this property.

=head2 value [$value]

Gets or sets the value of this property.

=head2 parameters [$param_hash]

Gets or sets the parameter hash reference of this property.  Parameter
keys are converted to upper case.

=head2 vcal10 [$bool]

Gets or sets a boolean saying whether this should be interpreted as
vCalendar 1.0 (as opposed to iCalendar 2.0).  Generally, you can just
set this on your main L<Data::ICal> object when you construct it;
C<add_entry> automatically makes sure that sub-entries end up with the
same value as their parents, and C<add_property> makes sure that
properties end up with the same value as their entry.

=cut

__PACKAGE__->mk_accessors(qw(key value _parameters vcal10));

sub parameters {
    my $self = shift;

    if (@_) {
        my $params     = shift;
        my $new_params = {};
        while ( my ( $k, $v ) = each %$params ) {
            $new_params->{ uc $k } = $v;
        }
        $self->_parameters($new_params);
    }

    return $self->_parameters;
}

my %ENCODINGS = (
    'QUOTED-PRINTABLE' => {
        encode => sub {
            my $dec = shift || '';
            $dec =~ s/\n/\r\n/g;
            return MIME::QuotedPrint::encode( $dec, '' );
        },
        decode => sub {
            my $dec = MIME::QuotedPrint::decode( shift || '' );
            $dec =~ s/\r\n/\n/g;
            return $dec;
            }
    },
);

=head2 decoded_value

Gets the value of this property, converted from the encoding specified
in its encoding parameter.  (That is, C<value> will return the encoded
version; this will apply the encoding.)  If the encoding is not
specified or recognized, just returns the raw value.

=cut

sub decoded_value {
    my $self     = shift;
    my $value    = $self->value;
    my $encoding = uc( $self->parameters->{'ENCODING'} || "" );

    if ( $ENCODINGS{$encoding} ) {
        return $ENCODINGS{$encoding}{'decode'}->($value);
    } else {
        return $value;
    }
}

=head2 encode $encoding

Calls C<decoded_value> to get the current decoded value, then encodes
it in C<$encoding>, sets the value to that, and sets the encoding
parameter to C<$encoding>. (C<$encoding> is first converted to upper
case.)

If C<$encoding> is undef, deletes the encoding parameter and sets the
value to the decoded value.  Does nothing if the encoding is not
recognized.

=cut

sub encode {
    my $self     = shift;
    my $encoding = uc shift;

    my $decoded_value = $self->decoded_value;

    if ( not defined $encoding ) {
        $self->value($decoded_value);
        delete $self->parameters->{'ENCODING'};
    } elsif ( $ENCODINGS{$encoding} ) {
        $self->value( $ENCODINGS{$encoding}{'encode'}->($decoded_value) );
        $self->parameters->{'ENCODING'} = $encoding;
    }
    return $self;
}

=head2 as_string ARGS

Returns the property formatted as a string (including trailing
newline).

Takes named arguments:

=over

=item fold

Defaults to true. pass in a false value if you need to generate
non-rfc-compliant calendars.

=item crlf

Defaults to C<\x0d\x0a>, per RFC 2445 spec.  This option is primarily
for backwards compatability with version of this module prior to 0.16,
which used C<\x0a>.

=back

=cut

sub as_string {
    my $self = shift;
    my %args = (
        fold => 1,
        crlf => Data::ICal::Entry->CRLF,
        @_
    );
    my $string
        = uc( $self->key )
        . $self->_parameters_as_string . ":"
        . $self->_value_as_string( $self->key )
        . $args{crlf};

  # Assumption: the only place in an iCalendar that needs folding are property
  # lines
    if ( $args{'fold'} ) {
        return $self->_fold( $string, $args{crlf} );
    }

    return $string;
}

=begin private

=head2 _value_as_string

Returns the property's value as a string.  Comma and semicolon are not
escaped when the value is recur type (the key is rrule).

Values are quoted according the iCal spec, unless this is in vCal 1.0
mode.

=end private

=cut

sub _value_as_string {
    my $self  = shift;
    my $key   = shift;
    my $value = defined( $self->value() ) ? $self->value() : '';

    unless ( $self->vcal10 ) {
        $value =~ s/\\/\\\\/gs;
        $value =~ s/;/\\;/gs unless lc($key) eq 'rrule';
        $value =~ s/,/\\,/gs unless lc($key) eq 'rrule';
        $value =~ s/\x0d?\x0a/\\n/gs;
    }

    return $value;
}

=begin private

=head2 _parameters_as_string

Returns the property's parameters as a string.  Properties are sorted alphabetically
to aid testing.

=end private

=cut

sub _parameters_as_string {
    my $self = shift;
    my $out  = '';
    for my $name ( sort keys %{ $self->parameters } ) {
        my $value = $self->parameters->{$name};
        $out
            .= ';'
            . $name . '='
            . $self->_quoted_parameter_values(
            ref $value ? @$value : $value );
    }
    return $out;
}

=begin private

=head2 _quoted_parameter_values @values

Quotes any of the values in C<@values> that need to be quoted and
returns the quoted values joined by commas.

If any of the values contains a double-quote, erases it and emits a
warning.

=end private

=cut

sub _quoted_parameter_values {
    my $self   = shift;
    my @values = @_;

    for my $val (@values) {
        if ( $val =~ /"/ ) {

            # Get all the way back to the user's code
            local $Carp::CarpLevel = $Carp::CarpLevel + 1;
            carp "Invalid parameter value (contains double quote): $val";
            $val =~ tr/"//d;
        }
    }

    return join ',', map { /[;,:]/ ? qq("$_") : $_ } @values;
}

=begin private

=head2 _fold $string $crlf

Returns C<$string> folded with newlines and leading whitespace so that
each line is at most 75 characters.

(Note that it folds at 75 characters, not 75 bytes as specified in the
standard.)

If this is vCalendar 1.0 and encoded with QUOTED-PRINTABLE, does not
fold at all.

=end private

=cut

sub _fold {
    my $self   = shift;
    my $string = shift;
    my $crlf   = shift;

    my $quoted_printable = $self->vcal10
        && uc( $self->parameters->{'ENCODING'} || '' ) eq 'QUOTED-PRINTABLE';

    if ($quoted_printable) {

     # In old vcal, quoted-printable properties have different folding rules.
     # But some interop tests suggest it's wiser just to not fold for vcal 1.0
     # at all (in quoted-printable).
    } else {
        my $pos = 0;

        # Walk through the value, looking to replace 75 characters at
        # a time.  We assign to pos() to update where to pick up for
        # the next match.
        while ( $string =~ s/\G(.{75})(?=.)/$1$crlf / ) {
            $pos += 75 + length($crlf);
            pos($string) = $pos;
        }
    }

    return $string;
}

=head1 AUTHOR

Jesse Vincent C<< <jesse@bestpractical.com> >> with David Glasser,
Simon Wistow, and Alex Vandiver

=head1 LICENCE AND COPYRIGHT

Copyright (c) 2005 - 2009, Best Practical Solutions, LLC.  All rights reserved.

This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself. See L<perlartistic>.


=head1 DISCLAIMER OF WARRANTY

BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
NECESSARY SERVICING, REPAIR, OR CORRECTION.

IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
SUCH DAMAGES.

=cut

1;