File Coverage

blib/lib/Net/OpenID/Yadis.pm
Criterion Covered Total %
statement 22 24 91.6
branch n/a
condition n/a
subroutine 8 8 100.0
pod n/a
total 30 32 93.7


line stmt bran cond sub pod time code
1             package Net::OpenID::Yadis;
2             {
3             $Net::OpenID::Yadis::VERSION = '1.19';
4             }
5              
6 1     1   20547 use strict;
  1         2  
  1         24  
7 1     1   5 use warnings;
  1         2  
  1         28  
8              
9 1     1   5 use base qw(Exporter);
  1         1  
  1         95  
10 1     1   5 use Carp ();
  1         1  
  1         17  
11 1     1   535 use Net::OpenID::URIFetch;
  1         4  
  1         59  
12 1     1   2231 use XML::Simple;
  1         12636  
  1         7  
13 1     1   719 use Net::OpenID::Yadis::Service;
  1         2  
  1         29  
14 1     1   573 use Net::OpenID::Common;
  0            
  0            
15             use HTTP::Headers::Util qw(split_header_words);
16             use Encode;
17              
18             our @EXPORT = qw(YR_HEAD YR_GET YR_XRDS);
19              
20             use constant YR_GET => 1;
21             use constant YR_XRDS => 2;
22              
23             use fields (
24             'last_errcode', # last error code we got
25             'last_errtext', # last error code we got
26             'debug', # debug flag or codeblock
27             'consumer', # consumer object
28             'identity_url', # URL to be identified
29             'xrd_url', # URL of XRD file
30             'xrd_objects', # Yadis XRD decoded objects
31             );
32              
33             sub new {
34             my $self = shift;
35             $self = fields::new( $self ) unless ref $self;
36             my %opts = @_;
37              
38             $self->consumer(delete($opts{consumer}));
39              
40             $self->{debug} = delete $opts{debug};
41              
42             Carp::croak("Unknown options: " . join(", ", keys %opts)) if %opts;
43              
44             return $self;
45             }
46              
47             sub consumer { &_getset; }
48              
49             sub identity_url { &_getset; }
50             sub xrd_url { &_getset; }
51             sub xrd_objects { _pack_array(&_getset); }
52             sub _getset {
53             my $self = shift;
54             my $param = (caller(1))[3];
55             $param =~ s/.+:://;
56              
57             if (@_) {
58             my $val = shift;
59             Carp::croak("Too many parameters") if @_;
60             $self->{$param} = $val;
61             }
62             return $self->{$param};
63             }
64              
65             sub _debug {
66             my $self = shift;
67             return unless $self->{debug};
68              
69             if (ref $self->{debug} eq "CODE") {
70             $self->{debug}->($_[0]);
71             } else {
72             print STDERR "[DEBUG Net::OpenID::Yadis] $_[0]\n";
73             }
74             }
75              
76             sub _fail {
77             my $self = shift;
78             my ($code, $text) = @_;
79              
80             $text ||= {
81             'xrd_parse_error' => "Error occured since parsing yadis document.",
82             'xrd_format_error' => "This is not yadis document (not xrds format).",
83             'too_many_hops' => 'Too many hops by X-XRDS-Location.',
84             'empty_url' => 'Empty URL',
85             'no_yadis_document' => 'Cannot find yadis Document',
86             'url_gone' => 'URL is no longer available',
87             }->{$code};
88              
89             $self->{last_errcode} = $code;
90             $self->{last_errtext} = $text;
91              
92             $self->_debug("fail($code) $text");
93             wantarray ? () : undef;
94             }
95             sub err {
96             my $self = shift;
97             $self->{last_errcode} . ": " . $self->{last_errtext};
98             }
99             sub errcode {
100             my $self = shift;
101             $self->{last_errcode};
102             }
103             sub errtext {
104             my $self = shift;
105             $self->{last_errtext};
106             }
107             sub _clear_err {
108             my $self = shift;
109             $self->{last_errtext} = '';
110             $self->{last_errcode} = '';
111             }
112              
113             sub _get_contents {
114             my $self = shift;
115             my ($url, $final_url_ref, $content_ref, $headers_ref) = @_;
116              
117             # we do NOT do elimination here because
118             # if it's an HTML document, we are only ever looking at the headers, and
119             # if it's a YADIS document, elimination is not appropriate
120             # (YADIS is not HTML; film at 11)
121             my $res = Net::OpenID::URIFetch->fetch($url, $self->consumer);
122              
123             if ($res) {
124             $$final_url_ref = $res->final_uri;
125             my $headers = $res->headers;
126             foreach my $k (keys %$headers) {
127             $headers_ref->{$k} ||= $headers->{$k};
128             }
129             $$content_ref = $res->content;
130             return 1;
131             }
132             else {
133             return undef;
134             }
135             }
136              
137             sub parse_content_type {
138             # stolen from HTTP::Headers but returns lc charset
139             my $h = shift;
140             $h = $h->[0] if ref($h);
141             $h = "" unless defined $h;
142             my ($v) = (split_header_words($h), []);
143             my($ct, undef, %ct_param) = @$v;
144             $ct ||= '';
145             $ct = lc($ct);
146             $ct =~ s/\s+//;
147             my $charset = lc($ct_param{charset} || '');
148             $charset =~ s/^\s+//;
149             $charset =~ s/\s+\z//;
150             return ($ct, $charset);
151             }
152              
153             sub discover {
154             my $self = shift;
155             my $url = shift or return $self->_fail("empty_url");
156             my $count = shift || YR_GET;
157             Carp::croak("Too many parameters") if @_;
158              
159             # trim whitespace
160             $url =~ s/^\s+//;
161             $url =~ s/\s+$//;
162             return $self->_fail("empty_url") unless $url;
163              
164             my $final_url;
165             my %headers;
166              
167             my $xrd;
168             $self->_get_contents($url, \$final_url, \$xrd, \%headers) or return;
169              
170             $self->identity_url($final_url) if ($count < YR_XRDS);
171              
172             # (1) found YADIS/XRDS-Location headers
173             if ($count < YR_XRDS and
174             my $doc_url = $headers{'x-yadis-location'} || $headers{'x-xrds-location'}
175             ) {
176             return $self->discover($doc_url, YR_XRDS);
177             }
178              
179             # (2) is content type YADIS document?
180             my ($ctype, $charset) = parse_content_type($headers{'content-type'});
181             if ($ctype eq 'application/xrds+xml') {
182             #survey says Yes!
183             $self->xrd_url($final_url);
184              
185             return $self->parse_xrd($xrd);
186             }
187              
188             # (3) YADIS/XRDS-location might be in a tag.
189             if ( $ctype eq 'text/html' and
190             my ($meta) = grep {
191             my $heqv = lc($_->{'http-equiv'}||'');
192             $heqv eq 'x-yadis-location' || $heqv eq 'x-xrds-location'
193             }
194             @{OpenID::util::html_extract_linkmetas($xrd)->{meta}||[]}
195             ) {
196             return $self->discover($meta->{content}, YR_XRDS);
197             }
198             return $self->_fail($count == YR_GET ? "no_yadis_document" : "too_many_hops");
199             }
200              
201             sub parse_xrd {
202             my $self = shift;
203             my $xrd = shift;
204             Carp::croak("Too many parameters") if @_;
205              
206             my $xs_hash = XMLin($xrd) or return $self->_fail("xrd_parse_error");
207             ($xs_hash->{'xmlns'} and $xs_hash->{'xmlns'} eq 'xri://$xrd*($v*2.0)') or $self->_fail("xrd_format_error");
208             my %xmlns;
209             foreach (map { /^(xmlns:(.+))$/ and [$1,$2] } keys %$xs_hash) {
210             next unless ($_);
211             $xmlns{$_->[1]} = $xs_hash->{$_->[0]};
212             }
213             my @priority;
214             my @nopriority;
215             foreach my $service (_pack_array($xs_hash->{'XRD'}{'Service'})) {
216             bless $service, "Net::OpenID::Yadis::Service";
217             $service->{'Type'} or next;
218             $service->{'URI'} ||= $self->identity_url;
219              
220             foreach my $sname (keys %$service) {
221             foreach my $ns (keys %xmlns) {
222             $service->{"{$xmlns{$ns}}$1"} = delete $service->{$sname} if ($sname =~ /^${ns}:(.+)$/);
223             }
224             }
225             defined($service->{'priority'}) ? push(@priority,$service) : push(@nopriority,$service);
226             # Services without priority fields are lowest priority
227             }
228             my @service = sort {$a->{'priority'} <=> $b->{'priority'}} @priority;
229             push (@service,@nopriority);
230             foreach (grep {/^_protocol/} keys %$self) { delete $self->{$_} }
231              
232             $self->xrd_objects(\@service);
233             }
234              
235             sub _pack_array { wantarray ? ref($_[0]) eq 'ARRAY' ? @{$_[0]} : ($_[0]) : $_[0] }
236              
237             sub services {
238             my $self = shift;
239             my %protocols;
240             my @protocols;
241             my $code_ref;
242             my $protocol = undef;
243              
244             Carp::croak("You haven't called the discover method yet") unless $self->xrd_objects;
245              
246             foreach my $option (@_) {
247             Carp::croak("No further arguments allowed after code reference argument") if $code_ref;
248             my $ref = ref($option);
249             if ($ref eq 'CODE') {
250             $code_ref = $option;
251             } else {
252             my $default = {versionarray => []};
253              
254             $protocols{$option} = $default;
255             $protocol = $option;
256             push @protocols, $option;
257             }
258             }
259              
260             my @servers;
261             @servers = $self->xrd_objects if (keys %protocols == 0);
262             foreach my $key (@protocols) {
263             my $regex = $protocols{$key}->{urlregex} || $key;
264             my @ver = @{$protocols{$key}->{versionarray}};
265             my $ver_regex = @ver ? '('.join('|',map { $_ =~ s/\./\\./g; $_ } @ver).')' : '.+' ;
266             $regex =~ s/\\ver/$ver_regex/;
267              
268             push (@servers,map { $protocols{$key}->{objectclass} ? bless($_ , $protocols{$key}->{objectclass}) : $_ } grep {join(",",$_->Type) =~ /$regex/} $self->xrd_objects);
269             }
270              
271             @servers = $code_ref->(@servers) if ($code_ref);
272              
273             wantarray ? @servers : \@servers;
274             }
275              
276             1;
277             __END__