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