File Coverage

blib/lib/Data/v.pm

Criterion	Covered	Total	%
statement	18	18	100.0
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	24	24	100.0

package Data::v;

use warnings;
use strict;

use Carp;
use Scalar::Util 'blessed';
use List::MoreUtils 'any';

our $VERSION = '0.03';

use base 'Data::Header::Fields';

our %v_types = (
	'VCARD' => 'Data::v::Card',
);

sub new {
	my $class = shift;
	return $class->SUPER::new(
		tight_folding => 1,
		key_cmp       => \&default_key_cmp,
		parent        => $class->_default_parent,
		@_,
	);
}

sub default_key_cmp {
	my $a = shift;
	my $b = shift;

	$a = lc $a;
	$b = lc $b;

	return 0
		if $b =~ qr{^$a (?: ; | $)}xms;

	return $a cmp $b;
}

sub decode {
	my $self = shift;
	my $any  = shift;

	my $return_self = ref $self;
	$self = $self->new()
		if not ref $self;

	my $dhf = $self->SUPER::decode($any);
	my $lines = $dhf->_lines;

	my @v_entries;
	my $v_type;
	while (my $line = shift @{$lines}) {
		if ($line->key eq 'BEGIN') {
			$v_type = $line->value->as_string;
			croak 'unknown v-type "'.$v_type.'"'
				if not $v_types{$v_type};

			my $v_data = $v_types{$v_type}->new();
			my $v_entry = ($v_types{$v_type}.'::Entry')->new(
				'key'           => $v_type,
				'value'         => $v_data,
				'parent'        => $self,
			);
			$v_data->parent($v_entry);
			push @v_entries, $v_entry;
			next;
		}
		elsif ($line->key eq 'END') {
			croak 'BEGIN and END mismatch "'.$v_type.'" ne "'.$line->value->as_string.'"'
				if $v_type ne $line->value->as_string;

			$v_type = undef;
			next;
		}

		push @{$v_entries[-1]->value->_lines}, $line;
	}

	foreach my $v_entry (@v_entries) {
		$v_entry->value->rebless_lines;
	}

	if (not $return_self) {
		return \@v_entries;
	}

	$dhf->_lines(\@v_entries);
	return $dhf;
}

sub _read_lines {
	my $self = shift;
	my $any  = shift;

	my $fh = IO::Any->read($any);

	# put folded lines to an array http://tools.ietf.org/html/rfc2822#section-2.2.3
	my @lines;
	my $quoted_printable = 0;
	while (my $line = <$fh>) {
		# folded line
		if (($line =~ m/^\s/xms) or ($quoted_printable and ($lines[-1] =~ m/ = \r? \Z /xms))) {
			# ignore if the first line starts with white space
			next if not @lines;

			$lines[-1] .= $line;
			next;
		}

		# detect quoted-printable encoding which continues on a next lines when the line ends with "="
		my ($key, $value) = split(/:/, $line, 2);
		my @key_parts = split(/;/, $key);
		shift @key_parts;
		$quoted_printable = (any { $_ eq 'encoding=quoted-printable' } map { lc $_; } @key_parts);

		push @lines, $line;
	}

	close $fh;

	return @lines;
}

sub _default_parent {
	return 'Data::Header::Fields';
}

sub parent {
	my $self   = shift;
	$self->{'parent'} = shift
		if @_;

	return (ref $self ? $self->{'parent'} : $self->_default_parent);
}

1;

package Data::v::Card;

use base 'Data::v';

use List::MoreUtils 'any';
use Carp 'croak';

sub version { return $_[0]->get_value('version') || '2.1'; }

sub rebless_lines {
	my $self = shift;

	foreach my $line (@{$self->_lines}) {
		$line = Data::v::Card::Line->new(
			line   => $line,
			parent => $self,
		);
	}
}

sub _default_parent {
	return 'Data::v::Card::Entry';
}

sub line_ending {
	my $self = shift;
	return $self->parent->parent->line_ending(@_);
}

sub get_fields {
	my $self        = shift;
	my $field_name  = shift or croak 'field_name argument is mandatory';
	my $param_name  = shift;
	my $param_value = shift;

	my @fields = $self->SUPER::get_fields($field_name);
	if (defined $param_name) {
		@fields =
			grep { any { lc $_->value eq $param_value } $_->get_key_params($param_name) }
			@fields
		;
	}

	return @fields;
}

1;


package Data::v::Card::Line;

use base 'Data::Header::Fields::Line';

use Carp 'croak';
use MIME::QuotedPrint 'encode_qp', 'decode_qp';
use MIME::Base64 'encode_base64', 'decode_base64';
use Encode ();
use List::MoreUtils 'none';

use overload
	'""'  => \&as_string,
	'cmp' => \&Data::Header::Fields::Line::cmp,
;

sub new {
	my $class = shift;
	my $self  = $class->SUPER::new(
		@_,
	);
	$self->_decode_key_params;
	return $self;
}

sub version { return $_[0]->parent->version; }

sub params {
	my $self = shift;

	if (@_) {
		$self->{params} = shift;
	}
	$self->{params} = []
		if (not $self->{params});

	return $self->{params};
}

sub _decode_key_params {
	my $self = shift;

	my $key = $self->key;

	if ($key =~ m/^([^;]+);(.+)$/xms) {
		my $orig_key_name  = $1;
		my @raw_key_params = split /;/, $2;
		my @key_params;

		my $key_name = lc $orig_key_name;

		foreach my $key_param (@raw_key_params) {
			croak 'unknown key param "'.$key_param.'"'
				if $key_param !~ m/^ (?: ([^=]+) = )? (.+) $/xms;
			my $param_name = $1 || 'TYPE';
			my $param_str  = $2;

			push
				@key_params,
					map { Data::v::Param->new('name' => $param_name, 'value' => $_, 'parent' => $self) }
					(split(/,/, $param_str))
			;
		}

		$self->key($orig_key_name);
		$self->params(\@key_params);

		my $enc_type   = lc ($self->get_key_param_value('encoding') || '');
		if ($enc_type) {
			if ($enc_type eq 'quoted-printable') {
				$self->{value} = Data::Header::Fields::Value->new(
					decode_qp($self->{value})
				);
			}
			elsif ($enc_type eq 'base64') {
				$self->{value} = Data::Header::Fields::Value->new(
					decode_base64($self->{value})
				);
			}
			else {
				croak 'unknown encoding "'.$enc_type.'"';
			}
		}

		my $charset = lc ($self->get_key_param_value('charset') || '');
		$charset ||= 'utf8'
			if (none { $_ eq $key_name } qw(photo logo sound key));

		if ($charset) {
			$self->{'value'} = Data::Header::Fields::Value->new(
				eval { Encode::decode($charset, $self->{'value'}) }
			);
		}
	}

	if ((lc $self->key eq 'n') and (not $self->key->isa('Data::v::Card::Value::Name'))) {
		$self->{'value'} = Data::v::Card::Value::Name->new(    # not calling value() because the set doesn't affect the content of the value
			'value' => $self->value,
			'parent' => $self,
		);
	}
	elsif ((lc $self->key eq 'adr') and (not $self->key->isa('Data::v::Card::Value::Adr'))) {
		$self->{'value'} = Data::v::Card::Value::Adr->new(     # not calling value() because the set doesn't affect the content of the value
			'value'  => $self->value,
			'parent' => $self,
		);
	}

	return;
}

sub get_key_params {
	my $self       = shift;
	my $param_name = shift or croak 'param param_name is mandatory';
	my $params     = $self->params;

	$param_name = lc $param_name;
	return grep { lc $_->{'name'} eq $param_name } @{$params};
}

sub get_key_param {
	my $self       = shift;
	my $param_name = shift or croak 'param param_name is mandatory';

	my @params = $self->get_key_params($param_name);
	croak 'more then one key param with name "'.$param_name.'"'
		if @params > 1;

	return $params[0];
}

sub get_key_param_value {
	my $self       = shift;
	my $param_name = shift or croak 'param param_name is mandatory';

	my $param = $self->get_key_param($param_name);
	return undef if not $param;
	return $param->{'value'};
}

sub update_key_params {
	my $self        = shift;
	my $param_name  = shift or croak 'param param_name is mandatory';
	my $param_value = shift;

	# updating via array set
	if (ref $param_value) {
		my @new_params     = @{$param_value};

		# update existing
		foreach my $param (@{$self->params}) {
			$param->value(shift @new_params)    # will returns undefs if depleeted
				if ($param->name eq $param_name);
		}

		# add any additional new
		foreach my $add_value (@new_params) {
			push @{$self->{params}}, Data::v::Param->new(
				'parent' => $self,
				'name'   => $param_name,
				'value'  => $add_value,
			);
		}

		# remove any additional old
		$self->{params} = [
			grep { defined $_->{'value'} }
			@{$self->{params}}
		];
		return $self;
	}

	my @params = (
		map {
			($_->{'name'} eq $param_name ? $_->{value} = $param_value : ());
			$_;
		} @{$self->params}
	);

	return $self;
}

sub set_key_param {
	my $self        = shift;
	my $param_name  = shift or croak 'param param_name is mandatory';
	my $param_value = shift;

	my @params = $self->get_key_params($param_name);
	if ((@params > 0) or (ref $param_value)) {
		$self->update_key_params($param_name, $param_value);
	}
	elsif (@params == 0) {
		push @{$self->params}, Data::v::Param->new('name' => $param_name, 'value' => $param_value, 'parent' => $self);
	}
	else {
		croak 'more then one param field with name "'.$param_name.'"';
	}

	return $self;
}

sub rm_key_param {
	my $self        = shift;
	my $param_name  = shift or croak 'param param_name is mandatory';

	my @params = (
		grep {
			$_->name ne $param_name
		} @{$self->params}
	);
	$self->params(\@params);

	return $self;
}

sub _encode_key_params {
	my $self = shift;

	my $params = $self->params;
	return if scalar @{$params} == 0;
	my $key   = $self->key;

	my $charset = lc ($self->get_key_param_value('charset') || 'utf8');
	$self->{value} = eval { Encode::encode($charset, $self->{value}) };

	my $enc_type   = lc ($self->get_key_param_value('encoding') || '');
	if ($enc_type) {
		if ($enc_type eq 'quoted-printable') {
			$self->{value} = encode_qp($self->{value}, "");
		}
		elsif ($enc_type eq 'base64') {
			$self->{value} = encode_base64($self->{value}, "");
		}
		else {
			croak 'unknown encoding "'.$enc_type.'"';
		}
	}

	if ($self->version eq '2.1') {
		$key .= ';'.(
			join(
				';',
				(
					map  { $_->as_string }
					grep { defined $_->value }
					@{$params}
				),
			)
		);
	}
	elsif ($self->version ge '3.0') {
		my @types = map { $_->as_string } $self->get_key_params('type');
		$key .= ';'.(
			join(
				';',
				(
					map {
						(lc $_->name eq 'type')
						? ( @types ? ('TYPE='.join(',',splice(@types,0,scalar @types))) : () )
						: $_->as_string
					}
					grep { defined $_->value }
					@{$params}
				),
			)
		);
	}
	else {
		croak 'unsupported VCARD version '.$self->version;
	}

	$self->params(undef);
	$self->key($key);

	return;
}

sub as_string {
	my $self = shift;

	if (exists $self->{'original_line'}) {
		my $original_line = $self->{'original_line'};

		# make sure the line has line_ending, even the original one could be created without using ->new()
		$original_line .= $self->parent->line_ending
			if $original_line !~ m/ \n \Z /xms;

		return $original_line;
	}

	$self->_encode_key_params;

	my ($key, $value) = ($self->key, $self->value);
	#$value = String::Escape::printable($value);
	# FIXME ^^^ should be moved to _encode_key_params

	my $line = join(':', $key, $value);

	$line .= $self->parent->line_ending
		if $line !~ m/\n$/xms;

	$self->_decode_key_params;

	return $line;
}

1;

package Data::v::Card::Entry;

use base 'Data::Header::Fields::Line';

use overload
	'""'  => \&as_string,
	'cmp' => \&Data::Header::Fields::Line::cmp,
;

sub as_string {
	my $self = shift;

	return
		'BEGIN:VCARD'.$self->parent->line_ending
		.$self->value->as_string()
		.'END:VCARD'.$self->parent->line_ending
	;
}

1;

package Data::v::Card::Value::Name;

use base 'Data::Header::Fields::Value';

our @NAME_PART_TYPES = qw{family_name given_name additional_names honorific_prefixes honorific_suffixes};

use overload
	'""'  => \&Data::Header::Fields::Value::as_string,
	'cmp' => \&Data::Header::Fields::Value::cmp,
;

sub new {
	my $class = shift;
	my $self = $class->SUPER::new(@_);

	defined $self->{'value'}
	? $self->_parse_value()
	: $self->_update_value();

	return $self;
}

sub _update_value {
	my $self = shift;

	my @name_parts = map { $self->$_() } @NAME_PART_TYPES;
	# remove the undef fields from the end of the N
	while ((@name_parts) and (not defined $name_parts[-1])) {
		pop @name_parts;
	}
	@name_parts = map { defined $_ ? $_ : '' } @name_parts;

	$self->value(join(';', @name_parts));

	return $self;
}

sub _parse_value {
	my $self = shift;

	my $name_str = $self->{'value'};
	my @name_parts = split(/;/, $name_str);

	foreach my $name_part_type (@NAME_PART_TYPES) {
		my $name_part_value = shift @name_parts;
		$self->{$name_part_type} = $name_part_value;
	}

	return $self;
}

sub family_name {
	my $self   = shift;

	if (@_) {
		$self->{'family_name'} = shift;
		$self->_update_value();
	}
	return $self->{'family_name'};
}
sub given_name {
	my $self   = shift;
	if (@_) {
		$self->{'given_name'} = shift;
		$self->_update_value();
	}
	return $self->{'given_name'};
}
sub additional_names {
	my $self   = shift;
	if (@_) {
		$self->{'additional_names'} = shift;
		$self->_update_value();
	}
	return $self->{'additional_names'};
}
sub honorific_prefixes {
	my $self   = shift;
	if (@_) {
		$self->{'honorific_prefixes'} = shift;
		$self->_update_value();
	}
	return $self->{'honorific_prefixes'};
}
sub honorific_suffixes {
	my $self   = shift;
	if (@_) {
		$self->{'honorific_suffixes'} = shift;
		$self->_update_value();
	}
	return $self->{'honorific_suffixes'};
}

1;

package Data::v::Card::Value::Adr;

use base 'Data::Header::Fields::Value';

our @ADR_PART_TYPES = qw{po_box ext_address street city state postal_code country};

use overload
	'""'  => \&Data::Header::Fields::Value::as_string,
	'cmp' => \&Data::Header::Fields::Value::cmp,
;

sub new {
	my $class = shift;
	my $self = $class->SUPER::new(@_);

	defined $self->{'value'}
	? $self->_parse_value()
	: $self->_update_value();

	return $self;
}

sub _update_value {
	my $self = shift;

	my @adr_parts = map { $self->$_() } @ADR_PART_TYPES;
	# remove the undef fields from the end of the N
	while ((@adr_parts) and (not defined $adr_parts[-1])) {
		pop @adr_parts;
	}
	@adr_parts = map { defined $_ ? $_ : '' } @adr_parts;

	$self->value(join(';', @adr_parts));

	return $self;
}

sub _parse_value {
	my $self = shift;

	my $adr_str = $self->{'value'};
	$adr_str =~ s/ \r? \n \Z//xms;
	my @adr_parts = split(/;/, $adr_str);

	foreach my $adr_part_type (@ADR_PART_TYPES) {
		my $adr_part_value = shift @adr_parts;
		$self->{$adr_part_type} = $adr_part_value;
	}

	return $self;
}

sub po_box {
	my $self   = shift;

	if (@_) {
		$self->{'po_box'} = shift @_;
		$self->_update_value();
	}

	return $self->{'po_box'};
}
sub ext_address {
	my $self   = shift;

	if (@_) {
		$self->{'ext_address'} = shift @_;
		$self->_update_value();
	}

	return $self->{'ext_address'};
}
sub street {
	my $self   = shift;

	if (@_) {
		$self->{'street'} = shift @_;
		$self->_update_value();
	}

	return $self->{'street'};
}
sub city {
	my $self   = shift;

	if (@_) {
		$self->{'city'} = shift @_;
		$self->_update_value();
	}

	return $self->{'city'};
}
sub state {
	my $self   = shift;

	if (@_) {
		$self->{'state'} = shift @_;
		$self->_update_value();
	}

	return $self->{'state'};
}
sub postal_code {
	my $self   = shift;

	if (@_) {
		$self->{'postal_code'} = shift @_;
		$self->_update_value();
	}

	return $self->{'postal_code'};
}
sub country {
	my $self   = shift;

	if (@_) {
		$self->{'country'} = shift @_;
		$self->_update_value();
	}

	return $self->{'country'};
}

1;

package Data::v::Param;

use overload
	'""'  => \&as_string,
	'cmp' => \&Data::Header::Fields::Value::cmp,
;

sub new {
	my $class = shift;
	return bless {
		@_
	}, $class;
}

sub name {
	my $self   = shift;

	$self->{'name'} = shift @_
		if (@_);

	return $self->{'name'};
}

sub value {
	my $self   = shift;

	$self->{'value'} = shift @_
		if (@_);

	return $self->{'value'};
}

sub as_string {
	my $self   = shift;

	return
		(lc $self->name eq 'type')
		? $self->value
		: $self->name.'='.$self->value
	;
}

1;

package Data::v::Calendar;

use base 'Data::v';

1;


__END__