librdf-vcard-perl 0.012-1 / usr / share / perl5 / RDF / vCard / Line.pm

package RDF::vCard::Line;

use 5.008;
use strict;
use warnings;
no warnings qw(uninitialized);

use Encode;
use MIME::Base64;
use RDF::Trine::Namespace qw[xsd];
use RDF::TrineX::Functions
	-shortcuts,
	statement => { -as => 'rdf_statement' },
	literal   => { -as => 'rdf_literal' },
	iri       => { -as => 'rdf_resource' };
use URI::data;

sub V    { return 'http://www.w3.org/2006/vcard/ns#' . shift; }
sub VX   { return 'http://buzzword.org.uk/rdf/vcardx#' . shift; }
sub RDF  { return 'http://www.w3.org/1999/02/22-rdf-syntax-ns#' . shift; }
sub XSD  { return 'http://www.w3.org/2001/XMLSchema#' . shift; }

use namespace::clean;

use overload '""' => \&to_string;
our $VERSION = '0.012';

sub new
{
	my ($class, %options) = @_;
	die "Need to provide a property name\n"
		unless defined $options{property};
	$options{value} = [$options{value}]
		unless ref $options{value} eq 'ARRAY';
	$options{type_parameters} ||= [];
	bless { %options }, $class;
}

sub property
{
	my ($self) = @_;
	return $self->{property};
}

sub value
{
	my ($self) = @_;
	return $self->{value};
}

sub nvalue
{
	my ($self) = @_;
	my $value = $self->value;
	my @nvalue;
	foreach my $v (@$value)
	{
		push @nvalue, (ref($v) eq 'ARRAY' ? $v : [$v]);
	}
	return \@nvalue;
}

sub type_parameters
{
	my ($self) = @_;
	$self->{type_parameters} = {} unless ref $self->{type_parameters} eq 'HASH';
	return $self->{type_parameters};
}

sub property_order
{
	my ($self) = @_;
	my $p = lc $self->property;
	return 0 if $p eq 'version';
	return 1 if $p eq 'prodid';
	return 2 if $p eq 'source';
	return 3 if $p eq 'kind';
	return 4 if $p eq 'fn';
	return 5 if $p eq 'n';
	return 6 if $p eq 'org';
	return $p;
}

sub to_string
{
	my ($self) = @_;
	
	my $str = uc $self->property;
	if (keys %{ $self->type_parameters })
	{
		foreach my $parameter (sort keys %{ $self->type_parameters })
		{
			my $values = $self->type_parameters->{$parameter};
			$values = [$values]
				unless ref $values eq 'ARRAY';
			my $values_string = join ",", map { $self->_escape_value($_, is_tp=>1) } @$values;
			$str .= sprintf(";%s=%s", uc $parameter, $values_string);
		}
	}
	$str .= ":";
	$str .= $self->value_to_string;
	
	if (length $str > 75)
	{
		my $new = '';
		while (length $str > 64)
		{
			$new .= substr($str, 0, 64) . "\r\n ";
			$str  = substr($str, 64);
		}
		$new .= $str;
		$str  = $new;
	}
	
	return $str;
}

sub value_to_string
{
	my ($self) = @_;	
	my $str = join ";",
		map
		{ join ",", map { $self->_escape_value($_) } @{$_}; }
		@{ $self->nvalue };
	$str =~ s/;+$//;
	return $str;
}

sub _escape_value
{
	my ($self, $value, %options) = @_;
	
	if ($options{is_tp} and $value =~ /[;:,"]/)
	{
		$value =~ s/\\/\\\\/g;
		$value =~ s/\"/\\\"/g;
		return sprintf('"%s"', $value);
	}
	
	$value =~ s/\\/\\\\/g;
	
	$value =~ s/\r//g;
	$value =~ s/\n/\\n/g;
	$value =~ s/;/\\;/g;
	$value =~ s/,/\\,/g;
	
	return $value;
}

sub _unescape_value
{
	my ($self, $value, %options) = @_;
	
	$value =~ s/\\r//gi;
	$value =~ s/\\n/\n/gi;
	$value =~ s/\\;/;/g;
	$value =~ s/\\,/,/g;
	
	$value =~ s/\\\\/\\/g;
	
	return $value;
}

# RDF Export Stuff...

sub add_to_model
{
	my ($self, $model, $card_node) = @_;
	
	my $special_func = sprintf('_add_to_model_%s', uc $self->property);
	if ($self->can($special_func))
	{
		$self->$special_func($model, $card_node);
	}
	elsif ($self->property_node)
	{
		$model->add_statement(rdf_statement(
			$card_node,
			$self->property_node,
			$self->value_node,
			));
	}
	return $self;
}

sub value_node
{
	my ($self) = @_;

	return rdf_literal($self->value_to_string, undef, $xsd->date)
		if (defined $self->type_parameters and uc $self->type_parameters->{VALUE} eq 'DATE');

	return rdf_literal($self->value_to_string, undef, $xsd->dateTime)
		if (defined $self->type_parameters and uc $self->type_parameters->{VALUE} eq 'DATE-TIME');

	return rdf_resource($self->value_to_string)
		if (defined $self->type_parameters and uc $self->type_parameters->{VALUE} eq 'URI');

	if (defined $self->type_parameters
	and uc $self->type_parameters->{VALUE} eq 'BINARY'
	and uc $self->type_parameters->{ENCODING} eq 'B')
	{
		my $uri = URI->new('data:');
		if (ref $self->type_parameters->{TYPE} eq 'ARRAY')
		{
			$uri->media_type(sprintf('image/%s', lc $self->type_parameters->{TYPE}->[0]));
		}
		elsif (ref $self->type_parameters->{TYPE})
		{
			$uri->media_type(sprintf('image/%s', lc $self->type_parameters->{TYPE}));
		}
		else
		{
			$uri->media_type('application/octet-stream');
		}
		$uri->data( decode_base64($self->value->[0]) );
		return rdf_resource("$uri");
	}

	if (defined $self->type_parameters->{LANG})
	{
		return rdf_literal($self->value_to_string, $self->type_parameters->{LANG});
	}

	return rdf_literal($self->value_to_string);
}

sub property_node
{
	my ($self) = @_;
	
	return rdf_resource(V(lc $self->property))
		if lc $self->property =~ /^(adr|agent|email|geo|key|logo|
			n|org|photo|sound|tel|url|bday|category|class|fn|
			label|mailer|nickname|note|prodid|rev|role|sort\-string|
			title|tz|uid)$/xi;

	return rdf_resource(VX(lc $self->property))
		if lc $self->property =~ /^(kind|gender|sex|dday|
			anniversary|lang|member|caladruri|caluri|fburl|
			impp|source)$/xi;

	return rdf_resource(VX(lc $self->property))
		if lc $self->property =~ /^x-/;
	
	return;
}

{
	my %usage_type = (
		bbs      => V('BBS'),
		car      => V('Car'),
		cell     => V('Cell'),
		dom      => V('Dom'),
		fax      => V('Fax'),
		home     => V('Home'),
		internet => V('Internet'),
		intl     => V('Intl'),
		isdn     => V('ISDN'),
		modem    => V('Modem'),
		msg      => V('Msg'),
		pager    => V('Pager'),
		parcel   => V('Parcel'),
		pcs      => V('PCS'),
		postal   => V('Postal'),
		pref     => V('Pref'),
		video    => V('Video'),
		voice    => V('Voice'),
		work     => V('Work'),
		x400     => V('X400'),
		);

	my %intrinsic_type = (
		adr      => V('Address'),
		email    => V('Email'),
		impp     => VX('Impp'),
		label    => V('Label'),
		tel      => V('Tel'),
		);

	sub _add_to_model_typed_thing
	{
		my ($self, $model, $card_node) = @_;
		my $intermediate_node = RDF::Trine::Node::Blank->new;
		
		$model->add_statement(rdf_statement(
			$card_node,
			$self->property_node,
			$intermediate_node,
			));
		
		$model->add_statement(rdf_statement(
			$intermediate_node,
			rdf_resource(RDF('type')),
			rdf_resource($intrinsic_type{ lc $self->property }),
			))
			if $intrinsic_type{ lc $self->property };
		
		$model->add_statement(rdf_statement(
			$intermediate_node,
			rdf_resource(RDF('value')),
			$self->value_node,
			));
		
		if ($self->type_parameters)
		{
			foreach my $type (@{ $self->type_parameters->{TYPE} })
			{
				if ($usage_type{lc $type})
				{
					$model->add_statement(rdf_statement(
						$intermediate_node,
						rdf_resource(RDF('type')),
						rdf_resource($usage_type{lc $type}),
						));
				}
				$model->add_statement(rdf_statement(
					$intermediate_node,
					rdf_resource(VX('usage')),
					rdf_literal($type),
					));
			}
		}
		
		return $intermediate_node;  # useful for _add_to_model_ADR
	}

}

*_add_to_model_TEL   = \&_add_to_model_typed_thing;
*_add_to_model_EMAIL = \&_add_to_model_typed_thing;
*_add_to_model_LABEL = \&_add_to_model_typed_thing;
*_add_to_model_IMPP  = \&_add_to_model_typed_thing;

sub _add_to_model_AGENT
{
	warn "Outputting AGENT property to RDF not yet supported.";
}

sub _add_to_model_ADR
{
	my ($self, $model, $card_node) = @_;
	my $intermediate_node = $self->_add_to_model_typed_thing($model, $card_node);
	
	my @properties = (
		V('post-office-box'),
		V('extended-address'),
		V('street-address'),
		V('locality'),
		V('region'),
		V('postal-code'),
		V('country-name'),
		);
	my @components = @{ $self->nvalue };
	
	for (my $i=0; defined $properties[$i]; $i++)
	{
		next unless $components[$i] && @{ $components[$i] };
		
		foreach my $v (@{ $components[$i] })
		{
			$model->add_statement(rdf_statement(
				$intermediate_node,
				rdf_resource($properties[$i]),
				rdf_literal($v),
				));
		}
	}
	
	return $intermediate_node;
}

sub _add_to_model_GEO
{
	my ($self, $model, $card_node) = @_;
	my $intermediate_node = RDF::Trine::Node::Blank->new;
	
	my @properties = (
		V('latitude'),
		V('longitude'),
		);

	$model->add_statement(rdf_statement(
		$card_node,
		$self->property_node,
		$intermediate_node,
		));
	
	$model->add_statement(rdf_statement(
		$intermediate_node,
		rdf_resource(RDF('type')),
		rdf_resource(V('Location')),
		));

	my @components = @{ $self->nvalue };
	
	for (my $i=0; defined $properties[$i]; $i++)
	{
		next unless $components[$i] && @{ $components[$i] };
		
		foreach my $v (@{ $components[$i] })
		{
			$model->add_statement(rdf_statement(
				$intermediate_node,
				rdf_resource($properties[$i]),
				rdf_literal($v),
				));
		}
	}
		
	return $intermediate_node;
}

sub _add_to_model_N
{
	my ($self, $model, $card_node) = @_;
	my $intermediate_node = RDF::Trine::Node::Blank->new;
	
	my @properties = (
		V('family-name'),
		V('given-name'),
		V('additional-name'),
		V('honorific-suffix'),
		V('honorific-prefix'),
		);

	$model->add_statement(rdf_statement(
		$card_node,
		$self->property_node,
		$intermediate_node,
		));
	
	$model->add_statement(rdf_statement(
		$intermediate_node,
		rdf_resource(RDF('type')),
		rdf_resource(V('Name')),
		));

	my @components = @{ $self->nvalue };
	
	for (my $i=0; defined $properties[$i]; $i++)
	{
		next unless $components[$i] && @{ $components[$i] };
		
		foreach my $v (@{ $components[$i] })
		{
			$model->add_statement(rdf_statement(
				$intermediate_node,
				rdf_resource($properties[$i]),
				rdf_literal($v),
				));
		}
	}
	
	return $intermediate_node;
}

sub _add_to_model_ORG
{
	my ($self, $model, $card_node) = @_;

	my @units;
	foreach my $v1 (@{ $self->nvalue })
	{
		push @units, @$v1;
	}

	my $intermediate_node = RDF::Trine::Node::Blank->new;
	
	$model->add_statement(rdf_statement(
		$card_node,
		$self->property_node,
		$intermediate_node,
		));
	
	$model->add_statement(rdf_statement(
		$intermediate_node,
		rdf_resource(RDF('type')),
		rdf_resource(V('Organization')),
		));

	my $org = shift @units;

	if ($org)
	{
		$model->add_statement(rdf_statement(
			$intermediate_node,
			rdf_resource(V('organization-name')),
			rdf_literal($org),
			));
	}

	foreach my $u (@units)
	{
		$model->add_statement(rdf_statement(
			$intermediate_node,
			rdf_resource(V('organization-unit')),
			rdf_literal($u),
			));
	}
}

1;

__END__

=head1 NAME

RDF::vCard::Line - represents a line within a vCard

=head1 DESCRIPTION

Instances of this class correspond to lines within vCards, though
they could potentially be used as basis for other RFC 2425-based formats
such as iCalendar.

=head2 Constructor

=over

=item * C<< new(%options) >>

Returns a new RDF::vCard::Line object.

The only options worth worrying about are: B<property> (case-insensitive
property name), B<value> (arrayref or single string value), B<type_parameters>
(hashref of property-related parameters).

RDF::vCard::Entity overloads stringification, so you can do the following:

  my $line = RDF::vCard::Line->new(
    property        => 'email',
    value           => 'joe@example.net',
    type_parameters => { type=>['PREF','INTERNET'] },
    );
  print "$line\n" if $line =~ /internet/i;

=back

=head2 Methods

=over

=item * C<< to_string() >>

Formats the line according to RFC 2425 and RFC 2426.

=item * C<< add_to_model($model, $node) >>

Given an RDF::Trine::Model and an RDF::Trine::Node representing the
entity (i.e. vcard) that this line belongs to, adds triples to the
model for this line.

=item * C<< property() >>

Returns the line's property - e.g. "EMAIL".

=item * C<< property_node() >>

Returns the line's property as an RDF::Trine::Node that can be used as an
RDF predicate. Returns undef if a sensible URI cannot be found.

=item * C<< property_order() >>

Returns a string which can be used to sort a list of lines into a sensible
order.

=item * C<< value() >>

Returns an arrayref for the value. Each item in the arrayref could be a plain scalar,
or an arrayref of scalars. For example the arrayref representing this name:

  N:Smith;John;Edward,James

which is the vCard representation of somebody with surname Smith, given name
John and additional names (middle names) Edward and James, might be represented
with the following "value" arrayref:

  [
    'Smith',
    'John',
    ['Edward', 'James'],
  ]

or maybe:

  [
    ['Smith'],
    'John',
    ['Edward', 'James'],
  ]

That's why it's sometimes useful to have a normalised version of it...

=item * C<< nvalue() >>

Returns a normalised version of the arrayref for the value. It will always
be an arrayref of arrayrefs. For example:

  [
    ['Smith'],
    ['John'],
    ['Edward', 'James'],
  ]

=item * C<< value_node() >>

Returns the line's value as an RDF::Trine::Node that can be used as an
RDF object. For some complex properties (e.g. ADR, GEO, ORG, N, etc) the
result is not especially useful.

=item * C<< value_to_string() >>

Formats the line value according to RFC 2425 and RFC 2426.

=item * C<< type_parameters() >>

Returns the type_parameters hashref. Here be monsters (kinda).

=back

=head1 SEE ALSO

L<RDF::vCard>.

=head1 AUTHOR

Toby Inkster E<lt>tobyink@cpan.orgE<gt>.

=head1 COPYRIGHT

Copyright 2011 Toby Inkster

This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.