File Coverage

blib/lib/OpenID/Lite/RelyingParty/Discover/Parser/HTML.pm
Criterion Covered Total %
statement 37 37 100.0
branch 8 8 100.0
condition n/a
subroutine 8 8 100.0
pod 0 1 0.0
total 53 54 98.1


line stmt bran cond sub pod time code
1             package OpenID::Lite::RelyingParty::Discover::Parser::HTML;
2              
3 2     2   26 use Any::Moose;
  2         4  
  2         11  
4             with 'OpenID::Lite::Role::Parser';
5             with 'OpenID::Lite::Role::ErrorHandler';
6              
7 2     2   2201 use OpenID::Lite::RelyingParty::Discover::Service;
  2         7  
  2         40  
8 2     2   40 use OpenID::Lite::Constants::Namespace qw(SIGNON_2_0 SIGNON_1_1);
  2         4  
  2         90  
9 2     2   2022 use HTML::TreeBuilder::XPath;
  2         175925  
  2         33  
10              
11             sub parse {
12 10     10 0 62 my ( $self, $result ) = @_;
13              
14 10         77 my $rels = [
15             { namespace => SIGNON_2_0,
16             endpoint_rel => q{openid2.provider},
17             local_id_rel => q{openid2.local_id},
18             },
19             { namespace => SIGNON_1_1,
20             endpoint_rel => q{openid.server},
21             local_id_rel => q{openid.delegate},
22              
23             },
24             ];
25              
26 10         60 my $tree = HTML::TreeBuilder::XPath->new;
27 10         2175 $tree->parse( lc $result->content );
28              
29 10         9013 my $services = [];
30 10         26 for my $rel (@$rels) {
31 20         56 my $service = $self->_extract( $tree, $rel );
32 20 100       9344 if ($service) {
33 10         50 $service->claimed_identifier( $result->normalized_identifier );
34 10         24 push @$services, $service;
35             }
36             }
37              
38 10 100       45 return $self->ERROR(
39             q{Couldn't extract provider information for OpenID protocol})
40             unless @$services > 0;
41              
42 8         204 return $services;
43              
44             }
45              
46             sub _extract {
47 20     20   26 my ( $self, $tree, $rel ) = @_;
48 20 100       59 my $op_endpoint_url
49             = $tree->findvalue( $self->_build_xpath_with( $rel->{endpoint_rel} ) )
50             or return;
51              
52 10         20746 my $service = OpenID::Lite::RelyingParty::Discover::Service->new;
53 10         38 $service->add_uri($op_endpoint_url);
54 10         44 $service->add_type( $rel->{namespace} );
55 10         30 my $local_id
56             = $tree->findvalue( $self->_build_xpath_with( $rel->{local_id_rel} ) );
57 10 100       17457 $service->op_local_identifier($local_id) if $local_id;
58 10         22 return $service;
59             }
60              
61             sub _build_xpath_with {
62 30     30   38 my ( $self, $rel ) = @_;
63 30         189 return sprintf(q{/html/head/link[@rel="%s"][1]/@href}, $rel);
64             }
65              
66 2     2   844 no Any::Moose;
  2         5  
  2         18  
67             __PACKAGE__->meta->make_immutable;
68             1;
69