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

package Net::OpenID::Yadis;
$Net::OpenID::Yadis::VERSION = '1.20';
use strict;
use warnings;

use base qw(Exporter);
use Carp ();
use Net::OpenID::URIFetch;
use XML::Simple;
use Net::OpenID::Yadis::Service;
use Net::OpenID::Common;
use HTTP::Headers::Util qw(split_header_words);
use Encode;

our @EXPORT = qw(YR_HEAD YR_GET YR_XRDS);

use constant YR_GET => 1;
use constant YR_XRDS => 2;

use fields (
            'last_errcode',    # last error code we got
            'last_errtext',    # last error code we got
            'debug',           # debug flag or codeblock
            'consumer',        # consumer object
            'identity_url',    # URL to be identified
            'xrd_url',         # URL of XRD file
            'xrd_objects',     # Yadis XRD decoded objects
            );

sub new {
    my $self = shift;
    $self = fields::new( $self ) unless ref $self;
    my %opts = @_;

    $self->consumer(delete($opts{consumer}));

    $self->{debug} = delete $opts{debug};

    Carp::croak("Unknown options: " . join(", ", keys %opts)) if %opts;

    return $self;
}

sub consumer { &_getset; }

sub identity_url { &_getset; }
sub xrd_url { &_getset; }
sub xrd_objects { _pack_array(&_getset); }
sub _getset {
    my $self = shift;
    my $param = (caller(1))[3];
    $param =~ s/.+:://;

    if (@_) {
        my $val = shift;
        Carp::croak("Too many parameters") if @_;
        $self->{$param} = $val;
    }
    return $self->{$param};
}

sub _debug {
    my $self = shift;
    return unless $self->{debug};

    if (ref $self->{debug} eq "CODE") {
        $self->{debug}->($_[0]);
    } else {
        print STDERR "[DEBUG Net::OpenID::Yadis] $_[0]\n";
    }
}

sub _fail {
    my $self = shift;
    my ($code, $text) = @_;

    $text ||= {
        'xrd_parse_error' => "Error occured since parsing yadis document.",
        'xrd_format_error' => "This is not yadis document (not xrds format).",
        'too_many_hops' => 'Too many hops by X-XRDS-Location.',
        'empty_url' => 'Empty URL',
        'no_yadis_document' => 'Cannot find yadis Document',
        'url_gone' => 'URL is no longer available',
    }->{$code};

    $self->{last_errcode} = $code;
    $self->{last_errtext} = $text;

    $self->_debug("fail($code) $text");
    wantarray ? () : undef;
}
sub err {
    my $self = shift;
    $self->{last_errcode} . ": " . $self->{last_errtext};
}
sub errcode {
    my $self = shift;
    $self->{last_errcode};
}
sub errtext {
    my $self = shift;
    $self->{last_errtext};
}
sub _clear_err {
    my $self = shift;
    $self->{last_errtext} = '';
    $self->{last_errcode} = '';
}

sub _get_contents {
    my $self = shift;
    my  ($url, $final_url_ref, $content_ref, $headers_ref) = @_;

    # we do NOT do  elimination here because
    # if it's an HTML document, we are only ever looking at the headers, and
    # if it's a YADIS document,  elimination is not appropriate
    # (YADIS is not HTML; film at 11)
    my $res = Net::OpenID::URIFetch->fetch($url, $self->consumer);

    if ($res) {
        $$final_url_ref = $res->final_uri;
        my $headers = $res->headers;
        foreach my $k (keys %$headers) {
            $headers_ref->{$k} ||= $headers->{$k};
        }
        $$content_ref = $res->content;
        return 1;
    }
    else {
        return undef;
    }
}

sub parse_content_type {
    # stolen from HTTP::Headers but returns lc charset
    my $h = shift;
    $h = $h->[0] if ref($h);
    $h = "" unless defined $h;
    my ($v) = (split_header_words($h), []);
    my($ct, undef, %ct_param) = @$v;
    $ct ||= '';
    $ct = lc($ct);
    $ct =~ s/\s+//;
    my $charset = lc($ct_param{charset} || '');
    $charset =~ s/^\s+//;
    $charset =~ s/\s+\z//;
    return ($ct, $charset);
}

sub discover {
    my $self = shift;
    my $url = shift or return $self->_fail("empty_url");
    my $count = shift || YR_GET;
    Carp::croak("Too many parameters") if @_;

    # trim whitespace
    $url =~ s/^\s+//;
    $url =~ s/\s+$//;
    return $self->_fail("empty_url") unless $url;

    my $final_url;
    my %headers;

    my $xrd;
    $self->_get_contents($url, \$final_url, \$xrd, \%headers) or return;

    $self->identity_url($final_url) if ($count < YR_XRDS);

    # (1) found YADIS/XRDS-Location headers
    if ($count < YR_XRDS and
        my $doc_url = $headers{'x-yadis-location'} || $headers{'x-xrds-location'}
       ) {
        return $self->discover($doc_url, YR_XRDS);
    }

    # (2) is content type YADIS document?
    my ($ctype, $charset) = parse_content_type($headers{'content-type'});
    if ($ctype eq 'application/xrds+xml') {
        #survey says Yes!
        $self->xrd_url($final_url);

        return $self->parse_xrd($xrd);
    }

    # (3) YADIS/XRDS-location might be in a  tag.
    if ( $ctype eq 'text/html' and
            my ($meta) = grep {
                my $heqv = lc($_->{'http-equiv'}||'');
                $heqv eq 'x-yadis-location' || $heqv eq 'x-xrds-location'
            }
            @{OpenID::util::html_extract_linkmetas($xrd)->{meta}||[]}
          ) {
        return $self->discover($meta->{content}, YR_XRDS);
    }
    return $self->_fail($count == YR_GET ? "no_yadis_document" : "too_many_hops");
}

sub parse_xrd {
    my $self = shift;
    my $xrd = shift;
    Carp::croak("Too many parameters") if @_;

    my $xs_hash = XMLin($xrd) or return $self->_fail("xrd_parse_error");
    ($xs_hash->{'xmlns'} and $xs_hash->{'xmlns'} eq 'xri://$xrd*($v*2.0)') or $self->_fail("xrd_format_error");
    my %xmlns;
    foreach (map { /^(xmlns:(.+))$/ and [$1,$2] } keys %$xs_hash) {
        next unless ($_);
        $xmlns{$_->[1]} = $xs_hash->{$_->[0]};
    }
    my @priority;
    my @nopriority;
    foreach my $service (_pack_array($xs_hash->{'XRD'}{'Service'})) {
        bless $service, "Net::OpenID::Yadis::Service";
        $service->{'Type'} or next;
        $service->{'URI'} ||= $self->identity_url;

        foreach my $sname (keys %$service) {
            foreach my $ns (keys %xmlns) {
                $service->{"{$xmlns{$ns}}$1"} = delete $service->{$sname} if ($sname =~ /^${ns}:(.+)$/);
            }
        }
        defined($service->{'priority'}) ? push(@priority,$service) : push(@nopriority,$service);
        # Services without priority fields are lowest priority
    }
    my @service = sort {$a->{'priority'} <=> $b->{'priority'}} @priority;
    push (@service,@nopriority);
    foreach (grep {/^_protocol/} keys %$self) { delete $self->{$_} }

    $self->xrd_objects(\@service);
}

sub _pack_array { wantarray ? ref($_[0]) eq 'ARRAY' ? @{$_[0]} : ($_[0]) : $_[0] }

sub services {
    my $self = shift;
    my %protocols;
    my @protocols;
    my $code_ref;
    my $protocol = undef;

    Carp::croak("You haven't called the discover method yet") unless $self->xrd_objects;

    foreach my $option (@_) {
        Carp::croak("No further arguments allowed after code reference argument") if $code_ref;
        my $ref = ref($option);
        if ($ref eq 'CODE') {
            $code_ref = $option;
        } else {
            my $default = {versionarray => []};

            $protocols{$option} = $default;
            $protocol = $option;
            push @protocols, $option;
        }
    }

    my @servers;
    @servers = $self->xrd_objects if (keys %protocols == 0);
    foreach my $key (@protocols) {
        my $regex = $protocols{$key}->{urlregex} || $key;
        my @ver = @{$protocols{$key}->{versionarray}};
        my $ver_regex = @ver ? '('.join('|',map { $_ =~ s/\./\\./g; $_ } @ver).')' : '.+' ;
        $regex =~ s/\\ver/$ver_regex/;

        push (@servers,map { $protocols{$key}->{objectclass} ? bless($_ , $protocols{$key}->{objectclass}) : $_ } grep {join(",",$_->Type) =~ /$regex/} $self->xrd_objects);
    }

    @servers = $code_ref->(@servers) if ($code_ref);

    wantarray ? @servers : \@servers;
}

1;
__END__