librdf-vcard-perl 0.010-2 / usr / share / perl5 / RDF / vCard / Entity / WithXmlSupport.pm

package RDF::vCard::Entity::WithXmlSupport;

use 5.008;
use strict;
use constant NS => 'urn:ietf:params:xml:ns:vcard-4.0';

use Scalar::Util qw[blessed];
use XML::LibXML;

use base qw'RDF::vCard::Entity';
use namespace::clean;

our $VERSION = '0.010';

sub promote
{
	my ($class, $self) = @_;
	die "Cannot promote non-RDF::vCard::Entity object!\n"
		unless blessed($self) && $self->isa('RDF::vCard::Entity');
	warn ("RDF::vCard::XML::Entity may not work property when used with %s input.", ref($self))
		unless ref($self) eq 'RDF::vCard::Entity'
		    || ref($self) eq 'RDF::vCard::XML::Entity';
	return bless $self, $class;
}

sub to_xml
{
	my ($self) = @_;	
	my $document = XML::LibXML->new->parse_string(sprintf('<vcards xmlns="%s" />', NS));
	$self->add_to_document($document);
	return $document->toString;
}

sub add_to_document
{
	my ($self, $document) = @_;
	my $root   = $document->documentElement->addNewChild(NS, 'vcard');
	my @sorted = sort
		{ $a->property_order cmp $b->property_order }
		@{ $self->{lines} };
	foreach my $l (@sorted)
	{
		next if $l->property =~ /^(version|prodid)$/i;
		$self->_add_line_to_node($l, $root);
	}
	return $root;
}

sub _add_line_to_node
{
	my ($self, $line, $node) = @_;
	my $prop_node = $node->addNewChild(NS, lc $line->property);
	
	my $method = sprintf('_add_value_to_node_%s', lc $line->property);
	$method = '_add_value_to_node_GENERIC' unless $self->can($method);
	$self->$method($line, $prop_node);
	return $prop_node;
}

sub _add_value_to_node_GENERIC
{
	my ($self, $line, $node) = @_;
	
	my $type = lc $line->type_parameters->{value} ||  'text';
	my $val_node = $node->addNewChild(NS, $type);
	$val_node->appendText($line->_unescape_value($line->value_to_string));
	
	my %params = %{ $line->type_parameters };
	delete $params{value};
	if (%params)
	{
		my $params_node = $node->addNewChild(NS, 'parameters');
		while (my ($p,$v) = each %params)
		{
			next unless length $p && defined $v;
			
			if (ref $v eq 'ARRAY')
			{
				foreach my $v2 (@$v)
				{
					$params_node->addNewChild(NS, lc $p)->appendText($v2||'');
				}
			}
			else
			{
				$params_node->addNewChild(NS, lc $p)->appendText($v||'');
			}
		}
	}
	
	return $val_node;
}

sub _add_value_to_node_n
{
	my ($self, $line, $node) = @_;
	
	my @child_names = qw(surname given additional prefix suffix);
	my @components  = @{ $line->nvalue };
	for (my $i = 0; defined $child_names[$i]; $i++)
	{
		my $component_node = $node->addNewChild(NS, $child_names[$i]);
		
		foreach my $value (@{ $components[$i] })
		{
			$component_node->addNewChild(NS, 'text')->appendText($value);
		}
	}
	
	return $node->childNodes;
}

sub _add_value_to_node_adr
{
	my ($self, $line, $node) = @_;
	
	my @child_names = qw(pobox ext street locality region code country);
	my @components  = @{ $line->nvalue };
	for (my $i = 0; defined $child_names[$i]; $i++)
	{
		my $component_node = $node->addNewChild(NS, $child_names[$i]);
		
		foreach my $value (@{ $components[$i] })
		{
			$component_node->addNewChild(NS, 'text')->appendText($value);
		}
	}
	
	return $node->childNodes;
}

1;


__END__

=head1 NAME

RDF::vCard::Entity::WithXmlSupport - subclass of RDF::vCard::Entity

=head1 DESCRIPTION

Subclass of L<RDF::vCard::Entity> with XML output support.

Requires L<XML::LibXML>.

=head2 Constructor

=over

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

As per L<RDF::vCard::Entity>.

=item * C<< promote($entity) >>

Clones an existing L<RDF::vCard::Entity>, but adds XML support.

=back

=head2 Methods

As per L<RDF::vCard::Entity>, but also:

=over

=item * C<< to_xml() >>

Formats the object according to the vCard XML Internet Draft.

=item * C<< add_to_document($document) >>

Given an L<XML::LibXML::Document> object, adds the vCard data to the document
as a child of the root element.

=back

=head1 SEE ALSO

L<RDF::vCard>.

L<http://tools.ietf.org/id/draft-ietf-vcarddav-vcardxml-06.txt>.

=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.