File Coverage

blib/lib/OpenID/Lite/Provider/Discover/Parser.pm
Criterion Covered Total %
statement 4 6 66.6
branch n/a
condition n/a
subroutine 2 2 100.0
pod n/a
total 6 8 75.0


line stmt bran cond sub pod time code
1             package OpenID::Lite::Provider::Discover::Parser;
2              
3 2     2   9 use Any::Moose;
  2         5  
  2         12  
4 2     2   2906 use XML::LibXML;
  0            
  0            
5             use OpenID::Lite::Constants::Namespace qw(RETURN_TO);
6             with 'OpenID::Lite::Role::ErrorHandler';
7              
8             sub parse {
9             my ( $self, $result ) = @_;
10              
11             my $parser = XML::LibXML->new;
12             my $doc;
13             eval { $doc = $parser->parse_string( $result->content ); };
14             if ($@) {
15             return $self->ERROR( sprintf q{Failed to parse xrds "%s"}, $@ );
16             }
17              
18             my @xrd
19             = $doc->findnodes(q{*[local-name()='XRDS']/*[local-name()='XRD']});
20             return $self->ERROR( q{XRD element not found} )
21             unless @xrd > 0;
22              
23             my $xrd = $xrd[0];
24             my @service_nodes = $xrd->findnodes(q{*[local-name()='Service']});
25             for my $service_node ( @service_nodes ) {
26             my $urls = $self->_find_return_to($service_node);
27             return $urls if $urls;
28             }
29             return $self->ERROR(q{return_to not found.});
30             }
31              
32             sub _find_return_to {
33             my ( $self, $service_elem ) = @_;
34              
35             my @type_nodes = $service_elem->findnodes(q{*[local-name()='Type']});
36             my @types = grep {
37             my $t = $_->findvalue(q{text()});
38             return ($t && $t eq RETURN_TO)
39             } @type_nodes;
40              
41             return unless @types > 0;
42              
43             my @uri_nodes = $service_elem->findnodes(q{*[local-name()='URI']});
44              
45             # Schwartzian transform
46             my @uris = map { $_->[0] }
47             sort { $a->[1] <=> $b->[1] }
48             map {
49             [ $_->findvalue(q{text()}), $_->findvalue(q{@priority}) || 100 ]
50             } @uri_nodes;
51              
52             #my @uris = map { $_->findvalue(q{text()}) }
53             # sort {
54             # ( $a->findvalue(q{@priority}) || 100 )
55             # <=> ( $b->findvalue(q{@priority}) || 100 )
56             # } @uri_nodes;
57              
58             return unless @uris > 0;
59             return \@uris;
60             }
61              
62             no Any::Moose;
63             __PACKAGE__->meta->make_immutable;
64             1;
65