Protocol::Yadis - Asynchronous Yadis implementation
Index
Code Index:
NAME
Protocol::Yadis - Asynchronous Yadis implementation
SYNOPSIS
my $y = Protocol::Yadis->new(
http_req_cb => sub {
my ($url, $method, $headers, $body, $cb) = @_;
...
$cb->($url, $status, $headers, $body, $error);
}
);
$y->discover(
$url => sub {
my ($self, $document, $error) = @_;
if ($document) {
my $services = $document->services;
...
}
elsif ($error) {
die "Error: $error";
}
else {
die "Nothing found";
}
}
);
DESCRIPTION
This is an asynchronous lightweight but full Yadis implementation.
ATTRIBUTES
http_req_cb
my $y = Protocol::Yadis->new(
http_req_cb => sub {
my ($url, $method, $headers, $body, $cb) = @_;
...
$cb->($url, $status, $headers, $body, $error);
}
);
This is a required callback that is used to download documents from the network.
Don't forget, that redirects can occur. This callback must handle them properly.
That is why after finishing downloading, callback must be called with the final
$url.
Arguments that are passed to the request callback
- * url url where to start Yadis discovery
- * method request method
- * body request body
- * cb callback that must be called after download was completed
Arguments that must be passed to the response callback
- * url url from where the document was downloaded
- * status response status
- * body response body
- * error internal error
head_first
Do HEAD request first. Disabled by default.
METHODS
new
Creates a new Protocol::Yadis instance.
discover
$y->discover(
$url => sub {
my ($self, $document, $error) = @_;
if ($document) {
my $services = $document->services;
...
}
else {
die 'error';
}
}
);
Discover Yadis document at the url provided. Callback is called when discovery
was finished. If no document was passed there was an error during discovery.
Error is passed as the third parameter.
If a Yadis document was discovered you get Protocol::Yadis::Document instance
containing all the services.
AUTHOR
Viacheslav Tykhanovskyi, vti@cpan.org.
COPYRIGHT
Copyright (C) 2009, Viacheslav Tykhanovskyi.
This program is free software, you can redistribute it and/or modify it under
the same terms as Perl 5.10.
package Protocol::Yadis;
use strict;
use warnings;
require Carp;
use constant DEBUG => $ENV{PROTOCOL_YADIS_DEBUG} || 0;
use Protocol::Yadis::Document;
our $VERSION = '0.990102';
sub new {
my $class = shift;
my %param = @_;
my $self = {@_};
bless $self, $class;
Carp::croak('http_req_cb is required') unless $self->{http_req_cb};
$self->{_headers} = {'Accept' => 'application/xrds+xml'};
return $self;
}
sub http_req_cb { shift->{http_req_cb} }
sub head_first { shift->{head_first} }
sub discover {
my $self = shift;
my ($url, $cb) = @_;
my $method = $self->head_first ? 'HEAD' : 'GET';
if ($method eq 'GET') {
return $self->_initial_req($url, sub { $cb->(@_) });
}
else {
$self->_initial_head_req(
$url => sub {
my ($self, $location, $error) = @_;
return $cb->($self, undef, $error) if $error;
return $self->_initial_req($url, sub { $cb->(@_) })
unless $location;
return $self->_second_req($location => sub { $cb->(@_); });
}
);
}
}
sub _parse_document {
my $self = shift;
my ($headers, $body) = @_;
my $content_type = $headers->{'Content-Type'};
if ( $content_type
&& $content_type =~ m/^(?:application\/xrds\+xml|text\/xml);?/)
{
my $document = Protocol::Yadis::Document->parse($body);
return $document if $document;
}
return;
}
sub _initial_req {
my $self = shift;
my ($url, $cb) = @_;
$self->_initial_get_req(
$url => sub {
my ($self, $document, $location, $error) = @_;
# Error
return $cb->($self, undef, $error) if $error;
# Yadis document
return $cb->($self, $document) if $document;
# No new location
return $cb->($self) unless $location;
# New location
return $self->_second_req($location => $cb);
}
);
}
sub _initial_head_req {
my $self = shift;
my ($url, $cb) = @_;
warn 'HEAD request' if DEBUG;
$self->http_req_cb->(
$url, 'HEAD',
$self->{_headers},
undef => sub {
my ($url, $status, $headers, $body, $error) = @_;
# Error
return $cb->($self, undef, $error) if $error;
# Wrong response status
return $cb->($self, undef, 'Wrong response status')
unless $status && $status == 200;
# New location
if (my $location = $headers->{'X-XRDS-Location'}) {
warn 'Found X-XRDS-Location' if DEBUG;
return $cb->($self, $location);
}
# Nothing found
$cb->($self);
}
);
}
sub _initial_get_req {
my $self = shift;
my ($url, $cb) = @_;
warn 'GET request' if DEBUG;
$self->http_req_cb->(
$url, 'GET',
$self->{_headers},
undef => sub {
my ($url, $status, $headers, $body, $error) = @_;
# Pass the error
return $cb->($self, undef, undef, $error) if $error;
warn 'after user callback' if DEBUG;
# Wrong response status
return $cb->($self, undef, undef, 'Wrong response status')
unless $status && $status == 200;
warn 'status is ok' if DEBUG;
# New XRDS location found
if (my $location = $headers->{'X-XRDS-Location'}) {
warn 'Found X-XRDS-Location' if DEBUG;
# Response body
if ($body) {
warn 'Found body' if DEBUG;
my $document = $self->_parse_document($headers, $body);
# Yadis document discovered
return $cb->($self, $document) if $document;
}
warn 'no yadis was found' if DEBUG;
# Not a Yadis document, thus try new location
return $cb->($self, undef, $location);
}
warn 'No X-XRDS-Location header was found' if DEBUG;
# Response body
if ($body) {
my $document = $self->_parse_document($headers, $body);
# Yadis document discovered
return $cb->($self, $document) if $document;
warn 'Found HTML' if DEBUG;
my ($head) = ($body =~ m/<\s*head\s*>(.*?)<\/\s*head\s*>/is);
# Invalid HTML
return $cb->($self, undef, undef, 'No <head> was found')
unless $head;
my $location;
my $tags = _html_tag(\$head);
foreach my $tag (@$tags) {
next unless $tag->{name} eq 'meta';
my $attrs = $tag->{attrs};
next
unless %$attrs
&& $attrs->{'http-equiv'}
&& $attrs->{'http-equiv'} =~ m/^X-XRDS-Location$/i;
last if ($location = $attrs->{content});
}
# Try new location
return $cb->($self, undef, $location) if $location;
# No HTML <meta> information was found
return $cb->($self, undef, undef, 'No <meta> was found');
}
warn 'No body was found' if DEBUG;
return $cb->($self, undef, undef, 'No document was found');
}
);
}
sub _second_req {
my $self = shift;
my ($url, $cb) = @_;
warn 'Second GET request' if DEBUG;
$self->http_req_cb->(
$url, 'GET',
$self->{_headers},
undef => sub {
my ($url, $status, $headers, $body, $error) = @_;
# Error
return $cb->($self, undef, $error) if $error;
# Wrong response status
return $cb->($self, undef, 'Wrong response status')
unless $status && $status == 200;
# No document
return $cb->($self, undef, 'No body was found') unless $body;
# Found Yadis document
if (my $document = $self->_parse_document($headers, $body)) {
warn 'XRDS Document was found' if DEBUG;
return $cb->($self, $document);
}
# Nothing found
return $cb->($self);
}
);
}
# based on HTML::TagParser
sub _html_tag {
my $txtref = shift; # reference
my $flat = [];
while (
$$txtref =~ s{
^(?:[^<]*) < (?:
( / )? ( [^/!<>\s"'=]+ )
( (?:"[^"]*"|'[^']*'|[^"'<>])+ )?
|
(!-- .*? -- | ![^\-] .*? )
) \/?> ([^<]*)
}{}sxg
)
{
my $attrs;
if ($3) {
my $attr = $3;
my $name;
my $value;
while ($attr =~ s/^([^=]+)=//s) {
$name = lc $1;
$name =~ s/^\s*//s;
$name =~ s/\s*$//s;
$attr =~ s/^\s*//s;
if ($attr =~ m/^('|")/s) {
my $quote = $1;
$attr =~ s/^$quote(.*?)$quote//s;
$value = $1;
}
else {
$attr =~ s/^(.*?)\s*//s;
$value = $1;
}
$attrs->{$name} = $value;
}
}
next if defined $4;
my $hash = {
name => lc $2,
content => $5,
attrs => $attrs
};
push(@$flat, $hash);
}
return $flat;
}
1;
__END__