Net::Yadis::Discovery - Perl extension for discovering Yadis document from Yadis URL

  use Net::Yadis::Discovery;

  my $disc = Net::Yadis::Discovery->new(
                                         ua => $ua,       # LWP::UserAgent object
                                         cache => $cache  # Cache object
                                     );

  my $xrd = $disc->discover("http://id.example.com/") or Carp::croak($disc->err);

  print $disc->identity_url;       # Yadis URL (Final URL if redirected )
  print $disc->xrd_url;            # Yadis Resourse Descriptor URL

  foreach my $srv (@$xrd) {        # Loop for Each Service in Yadis Resourse Descriptor
    print $srv->priority;          # Service priority (sorted)
    print $srv->Type;              # Identifier of some version of some service (scalar, array or array ref)
    print $srv->URI;               # URI that resolves to a resource providing the service (scalar, array or array ref)
    print $srv->extra_field("Delegate","http://openid.net/xmlns/1.0");
                                   # Extra field of some service
  }

  my $xrd = $self->servers('openid'=>['1.0','1.1'],'typekey');
  # If you want to take only OpenID 1.0/1.1 and TypeKey servers.

  my $xrd = $self->servers(sub{($_[int(rand(@_))])});
  # If you want to choose random server by code-ref.

  http://yadis.org/

package Net::Yadis::Discovery;

use strict;
use warnings;
use vars qw($VERSION @EXPORT);
$VERSION = "0.05";

use base qw(Exporter);
use Carp ();
use URI::Fetch 0.02;
use XML::Simple;
use Module::Pluggable::Fast
    search => [ 'Net::Yadis::Discovery::Protocol' ],
    callback => sub { };
use Net::Yadis::Object;

@EXPORT = qw(YR_HEAD YR_GET YR_XRDS);

use constant {
    YR_HEAD => 0,
    YR_GET => 1,
    YR_XRDS => 2,
};

use fields (
            'cache',           # the Cache object sent to URI::Fetch
            '_ua',             # Custom LWP::UserAgent instance to use
            'last_errcode',    # last error code we got
            'last_errtext',    # last error code we got
            'debug',           # debug flag or codeblock
            '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->ua              ( delete $opts{ua}              );
    $self->cache           ( delete $opts{cache}           );

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

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

    $self->plugins;
    return $self;
}

sub cache   { &_getset; }
sub identity_url { &_getset; }
sub xrd_url { &_getset; }
sub xrd_objects { _pack_array(&_getset); }
sub _ua { &_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::Yadis::Discovery] $_[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 ua {
    my $self = shift;
    my $ua = shift if @_;
    Carp::croak("Too many parameters") if @_;

    if (($ua) || (!$self->{_ua})) {
        $self->{_ua} = Net::Yadis::Discovery::UA->new($ua);
    }

    $self->{_ua}->{'ua'};
}

sub _get_contents {
    my $self = shift;

    my  ($url, $final_url_ref, $content_ref, $headers_ref) = @_;
    $final_url_ref ||= do { my $dummy; \$dummy; };

    my $ures = URI::Fetch->fetch($url,
                                 UserAgent        => $self->_ua,
                                 Cache            => $self->_ua->force_head ? undef : $self->cache,
                                 ContentAlterHook =>  sub {my $htmlref = shift;$$htmlref =~ s/<body\b.*//is;},
                                 )
        or return $self->_fail("url_fetch_error", "Error fetching URL: " . URI::Fetch->errstr);

    if ($ures->status == URI::Fetch::URI_GONE()) {
        return $self->_fail("url_gone");
    }
    
    my $res = $ures->http_response;

    $$final_url_ref = $res->request->uri->as_string;
    $res->headers->scan(sub{$headers_ref->{lc($_[0])} ||= $_[1];});
    $$content_ref = $ures->content;

    return 1;
}

sub discover {
    my $self = shift;
    my $url = shift or return $self->_fail("empty_url");
    my $count = shift || YR_HEAD;                              # $count = YR_HEAD:HEAD request YR_GET:GET request YR_XRDS:XRDS request
    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;

    $self->_ua->force_head(1) if ($count == YR_HEAD);

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

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

    my $doc_url;
    if (($doc_url = $headers{'x-yadis-location'} || $headers{'x-xrds-location'}) && ($count < YR_XRDS)) {
        return $self->discover($doc_url,YR_XRDS);
    } elsif ($headers{'content-type'} eq 'application/xrds+xml') {
        return $self->discover($final_url,YR_XRDS) if ((!$xrd) && ($count == YR_HEAD));
        $self->xrd_url($final_url);
        return $self->parse_xrd($xrd);
    }

    return $count == YR_HEAD ? $self->discover($final_url,YR_GET) : $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::Yadis::Object";
        $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 servers {
    my $self = shift;
    my %protocols;
    my $code_ref;
    my $protocol = undef;
    
    Carp::croak("Not calling discover method yet") unless $self->xrd_objects;

    foreach my $option (@_) {
        Carp::croak("No option allow after code reference option") if $code_ref;
        my $ref = ref($option);
        if ($ref eq 'CODE') {
            $code_ref = $option;
        } elsif ($ref eq 'ARRAY') {
            Carp::croak("Version array option needs protocol name or URL") unless $protocol;
            $protocols{$protocol}->{versionarray} = $option;
            $protocol = undef;
        } else {
            my $default = {versionarray => []};
            unless ($option =~ /^http/) {
                my $method = "${option}_regex";
                Carp::croak("Unknown protocol: $option") unless $self->can($method);
                $default->{urlregex} = $self->$method;
                $method = "${option}_objectclass";
                $default->{objectclass} = $self->$method if $self->can($method);
            }

            $protocols{$option} = $default;
            $protocol = $option;
        }
    }

    my @servers;
    @servers = $self->xrd_objects if (keys %protocols == 0);
    foreach my $key (keys %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;
}

package Net::Yadis::Discovery::UA;

# This module is decolation module to LWP::UserAgent.
# This add application/xrds+xml HTTP header and GET method to request object used in URI::Fetch.

use strict;
use warnings;
use LWP::UserAgent;
use vars qw($AUTOLOAD $lwpclass);

BEGIN {
    eval "use LWPx::ParanoidAgent;";
    $lwpclass = $@ ? "LWP::UserAgent" : "LWPx::ParanoidAgent";
}

sub new {
    my $class = shift;
    my $ua = shift; 
    unless ($ua) {
        $ua = $lwpclass->new;
        $ua->timeout(10);
    }
    bless {ua => $ua,force_head => 0},$class;
}

sub request {
    my $self = shift;
    my $req = shift;
    $req->header('Accept' => 'application/xrds+xml');
    $req->method($self->force_head ? "HEAD" : "GET");
    $self->force_head(0);
    $self->{'ua'}->request($req);
}

sub force_head {
    $_[0]->{'force_head'} = $_[1] if defined($_[1]);
    $_[0]->{'force_head'};
}

sub AUTOLOAD {
    my $self = shift;
    return if $AUTOLOAD =~ /::DESTROY$/;
    $AUTOLOAD =~ s/.*:://;
    $self->{'ua'}->$AUTOLOAD(@_);
}

1;
__END__