package Protocol::Yadis::Document;
use strict;
use warnings;
use overload '""' => sub { shift->to_string }, fallback => 1;
use Protocol::Yadis::Document::Service;
use Protocol::Yadis::Document::Service::Element;
use XML::LibXML;
sub new {
my $class = shift;
my %param = @_;
my $self = {};
bless $self, $class;
$self->{_services} ||= [];
return $self;
}
sub services {
my $self = shift;
if (@_) {
$self->{_services} = [];
return $self;
}
else {
my @priority =
grep { defined $_->attr('priority') } @{$self->{_services}};
my @other =
grep { not defined $_->attr('priority') } @{$self->{_services}};
my @sorted =
sort { $a->attr('priority') cmp $b->attr('priority') } @priority;
push @sorted, @other;
return [@sorted];
}
return $self->{_services};
}
sub parse {
my $class = shift;
my $document = shift;
my $self = $class->new;
return unless $document;
my $parser = XML::LibXML->new;
my $doc;
eval {$doc = $parser->parse_string($document); };
return if $@;
# Get XRDS
my $xrds = shift @{$doc->getElementsByTagName('xrds:XRDS')};
$xrds = shift @{$doc->getElementsByTagName('XRDS')} unless $xrds;
return unless $xrds;
# Get /last/ XRD
my @xrd = $xrds->getElementsByTagName('XRD');
my $xrd = $xrd[-1];
return unless $xrd;
my $services = [];
my @services = $xrd->getElementsByTagName('Service');
foreach my $service (@services) {
my $s =
Protocol::Yadis::Document::Service->new(attrs =>
[map { $_->getName => $_->getValue } $service->attributes]);
my $elements = [];
my @nodes = $service->childNodes;
foreach my $node (@nodes) {
next unless $node->isa('XML::LibXML::Element');
my @attrs = $node->attributes;
my $content = $node->textContent;
$content =~ s/^\s*//s;
$content =~ s/\s*$//s;
my $element = Protocol::Yadis::Document::Service::Element->new(
name => $node->getName,
content => $content,
attrs => [map { $_->getName => $_->getValue } @attrs]
);
push @$elements, $element;
}
$s->elements($elements);
next unless $s->Type;
push @{$self->{_services}}, $s;
}
return $self;
}
sub to_string {
my $self = shift;
my $string = '';
$string .= '<?xml version="1.0" encoding="UTF-8"?>' . "\n";
$string .= ' <xrds:XRDS xmlns:xrds="xri://" xmlns="xri://*(*2.0)"' . "\n";
$string .= ' xmlns:openid="http://openid.net/xmlns/1.0">' . "\n";
$string .= " <XRD>\n";
foreach my $service (@{$self->services}) {
$string .= $service->to_string;
}
$string .= " </XRD>\n";
$string .= "</xrds:XRDS>\n";
return $string;
}
1;
__END__
=head1 NAME
Protocol::Yadis::Document - Protocol::Yadis document object
=head1 SYNOPSIS
my $d = Protocol::Yadis::Document->parse(<<EOD);
<?xml version="1.0" encoding="UTF-8"?>
<xrds:XRDS xmlns:xrds="xri://$xrds" xmlns="xri://$xrd*($v*2.0)">
<XRD>
<Service>
<Type> http://lid.netmesh.org/sso/2.0 </Type>
</Service>
<Service>
<Type> http://lid.netmesh.org/sso/1.0 </Type>
</Service>
</XRD>
</xrds:XRDS>
my $services = $d->services;
=head1 DESCRIPTION
This is a document object for L<Protocol::Yadis>.
=head1 METHODS
=head2 C<new>
Creates a new L<Protocol::Yadis::Document> instance.
=head2 C<services>
Returns discovered Yadis services.
=head2 C<parse>
Parses XML document.
=head2 C<to_string>
String representation.
=head1 AUTHOR
Viacheslav Tykhanovskyi, C<vti@cpan.org>.
=head1 COPYRIGHT
Copyright (C) 2009, Viacheslav Tykhanovskyi.
This program is free software, you can redistribute it and/or modify it under
the same terms as Perl 5.10.
=cut