File Coverage

blib/lib/Protocol/Yadis.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition	1	2	50.0
subroutine	4	4	100.0
pod			n/a
total	15	18	83.3

package Protocol::Yadis;

use strict;
use warnings;

require Carp;

use constant DEBUG => $ENV{PROTOCOL_YADIS_DEBUG} || 0;

use Protocol::Yadis::Document;

our $VERSION = '1.00';

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  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  information was found
                return $cb->($self, undef, undef, 'No  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__