File Coverage

blib/lib/Feed/Find.pm

Criterion	Covered	Total	%
statement	75	79	94.9
branch	22	30	73.3
condition	3	6	50.0
subroutine	14	14	100.0
pod	2	2	100.0
total	116	131	88.5

package Feed::Find;
use strict;
use warnings;
use 5.008_001;

use base qw( Class::ErrorHandler );
use LWP::UserAgent;
use HTML::Parser;
use URI;
use Carp;

use vars qw( $VERSION $ua );
$VERSION = '0.13';

use constant FEED_MIME_TYPES => [
    'application/x.atom+xml',
    'application/atom+xml',
    'application/xml',
    'text/xml',
    'application/rss+xml',
    'application/rdf+xml',
];

my $FEED_EXT = qr/\.(?:rss|xml|rdf|atom)$/;
my %IsFeed = map { $_ => 1 } @{ FEED_MIME_TYPES() };

sub find {
    my $class = shift;
    my($uri) = @_;
    $ua = LWP::UserAgent->new unless defined $ua;
    $ua->env_proxy;
    $ua->agent(join '/', $class, $class->VERSION);
    $ua->parse_head(0);   ## We're already basically doing this ourselves.
    my $req = HTTP::Request->new(GET => $uri);
    my $p = HTML::Parser->new(api_version => 3,
        start_h => [ \&_find_links, 'self,tagname,attr' ]);
    $p->{base_uri} = $uri;
    $p->{feeds} = [];
    my $res = $ua->request($req, sub {
        my($chunk, $res, $proto) = @_;
        if ($IsFeed{$res->content_type}) {
            push @{ $p->{feeds} }, $uri;
            croak 'Done parsing';
        }
        $p->parse($chunk) or croak 'Done parsing';
    });
    return $class->error($res->status_line) unless $res->is_success;
    return @{ $p->{feeds} };
}

sub find_in_html {
    my $class = shift;
    my($html, $base_uri) = @_;
    my $p = HTML::Parser->new(api_version => 3,
        start_h => [ \&_find_links, 'self,tagname,attr' ]);
    $p->{base_uri} = $base_uri;
    $p->{feeds} = [];
    $p->parse($$html);
    return @{ $p->{feeds} };
}

sub _find_links {
    my($p, $tag, $attr) = @_;

    my %head_tag = map { $_ => 1 }
      qw[ meta isindex title script style head html ];

    my $base_uri = $p->{base_uri};
    if ($tag eq 'link') {
        return unless $attr->{rel};
        my %rel = map { $_ => 1 } split /\s+/, lc($attr->{rel});
        my $type = '';
        if ($attr->{type}) {
            ($type = lc $attr->{type}) =~ s/^\s*//;
            $type =~ s/\s*$//;
        }
        push @{ $p->{feeds} }, URI->new_abs($attr->{href}, $base_uri)->as_string
                if $IsFeed{$type} &&
                   ($rel{alternate} || $rel{'service.feed'});
    } elsif ($tag eq 'base') {
        $p->{base_uri} = $attr->{href} if $attr->{href};
    } elsif ($head_tag{$tag}) {
        ## Ignore other valid tags inside of .
    } elsif ($tag eq 'a') {
        my $href = $attr->{href} or return;
        my $uri = URI->new($href);
        push @{ $p->{feeds} }, URI->new_abs($href, $base_uri)->as_string
            if $uri->path =~ /$FEED_EXT/io;
    } else {
        ## Anything else indicates the start of the ,
        ## so we stop parsing.
        $p->eof if @{ $p->{feeds} };
    }

    return;
}

1;
__END__