File Coverage

blib/lib/Mojo/Feed.pm

Criterion	Covered	Total	%
statement	129	134	96.2
branch	36	44	81.8
condition	21	31	67.7
subroutine	28	29	96.5
pod	5	6	83.3
total	219	244	89.7

package Mojo::Feed;
use Mojo::Base '-base';
use Mojo::DOM;
use Mojo::File;
use Mojo::URL;
use Mojo::UserAgent;
use Mojo::Util qw(decode trim);

use Carp qw(croak);
use List::Util;
use HTTP::Date qw(str2time);

use Mojo::Feed::Item;

use overload
  bool     => sub { shift->is_valid },
  '""'     => sub { shift->to_string },
  fallback => 1;

our $VERSION = "0.21";

has charset => 'UTF-8';

has ua            => sub { Mojo::UserAgent->new() };
has max_redirects => sub { $ENV{MOJO_MAX_REDIRECTS} || 3 };
has redirects     => sub { [] };
has related       => sub { [] };

has url  => sub { Mojo::URL->new() };
has file => sub { Mojo::File->new() };
has source => sub {
  my $self = shift;
  return
      ($self->url ne '') ? $self->url
    : (-f $self->file)   ? $self->file
    :                      undef;
};

has body => sub {
  my $self = shift;
  if ($self->url ne '') {
    return $self->_load();
  }
  else {    # skip file tests, just slurp (for Mojo::Asset::File)
    return $self->file->slurp();
  }
};

has text => sub {
  my $self = shift;
  return decode($self->charset, $self->body) || '';
};

has dom => sub {
  my ($self) = @_;
  return Mojo::DOM->new($self->text);
};

# The top node, not the root
has top => sub { shift->dom->children->first };

has feed_type => sub {
  my $top     = shift->top;
  my $tag     = $top->tag;
  my $version = $top->attr('version');
  my $ns      = $top->namespace;
  return
      ($tag =~ /feed/i)
    ? ($version)
      ? 'Atom ' . $version
      : 'Atom 1.0'
    : ($tag =~ /rss/i) ? 'RSS ' . $version
    : ($tag =~ /rdf/i) ? 'RSS 1.0'
    :                    'unknown';
};

has namespaces => sub {
  my $top = shift->top;
  my $namespaces = { atom => $top->namespace };  # only Atom feeds declare a namespace?
  my $attrs = $top->attr;
  for my $at (keys %$attrs) {
    if ($at =~ /xmlns\:(\w+)/) { # extra namespace declaration
      $namespaces->{$1} = $attrs->{$at};
    }
  }
  return $namespaces;
};

my %generic = (
  description => ['description', 'tagline', 'subtitle'],
  published   => [
    'published', 'pubDate', 'dc|date', 'created',
    'issued',    'updated', 'modified'
  ],
  author   => ['author', 'dc|creator', 'webMaster', 'copyright'],
  title    => ['title'],
  subtitle => ['subtitle', 'tagline'],
  link     => ['link:not([rel])', 'link[rel=alternate]'],
);

sub _get_selector {
  my ($self, $k) = @_;
    for my $generic (@{$generic{$k}}) {
      if (my $p = $self->dom->at("channel > $generic, feed > $generic", %{$self->namespaces})) {
        if ($k eq 'author' && $p->at('name')) {
          return trim $p->at('name')->text;
        }
        my $text = trim($p->text || $p->content || $p->attr('href') || '');
        if ($k eq 'published') {
          return str2time($text);
        }
        return $text;
      }
    }
};

sub _set_selector {
  my ($self, $k, $val) = @_;
    for my $generic (@{$generic{$k}}) {
      if (my $p = $self->dom->at("channel > $generic, feed > $generic", %{$self->namespaces})) {
        if ($k eq 'author' && $p->at('name')) {
          return $p->at('name')->content($val);
        }
        if ($k eq 'published') {
          return $p->content(Mojo::Date->new($val)->to_datetime());  # let's pretend we're all OK with Atom dates
        }
        return $p->content($val);
      }
    }
};
foreach my $k (keys %generic) {
  has $k => sub { return shift->_get_selector($k) || undef; };
}

has items => sub {
  my $self = shift;
  $self->dom->find('item, entry')
    ->map(sub { Mojo::Feed::Item->new(dom => $_, feed => $self) });
};

# alias
sub entries { shift->items() };

# change the underlying DOM when we change the items list:
sub set_items {
  my ($self, $new_items) = @_;
  $self->dom->find('item, entry')->each(sub { $_->remove() });
  $new_items->each(sub { $self->top->append($_->dom) });
  return $self->items($new_items);
};

has is_valid => sub {
  shift->dom->children->first->tag =~ /^(feed|rss|rdf|rdf:rdf)$/i;
};

sub is_feed_content_type {
  my ($self, $content_type) = @_;
  # use split to remove charset attribute from content_type header
  ($content_type) = split(/[; ]+/, $content_type);
# feed mime-types:
  my @feed_types = (
    'application/x.atom+xml', 'application/atom+xml',
    'application/xml',        'text/xml',
    'application/rss+xml',    'application/rdf+xml'
  );
  return List::Util::first { $_ eq $content_type } @feed_types;
}


sub _load {
  my ($self) = @_;
  my $tx     = $self->ua->get($self->url);
  my $result = $tx->result;                  # this will croak on network errors

  if ($result->is_error) {
    $self->is_valid(undef);
    croak "Error getting feed from url ", $self->url, ": ", $result->message;
  }

  # Redirect:
  elsif ($result->code == 301 || $result->code == 302) {
    my $new_url = Mojo::URL->new($result->headers->location);
    push @{$self->redirects}, $self->url;
    $self->url($new_url);
    if (@{$self->redirects} > $self->max_redirects) {
      $self->is_valid(undef);
      croak "Number of redirects exceeded when loading feed"
    }
    return $self->_load();
  }

  # Is this a feed (by content type)?
  if ($self->is_feed_content_type($result->headers->content_type)) {
    $self->charset($result->content->charset) if ($result->content->charset);
    return $result->body;
  }
  else {
    # we are in a web page. PHEAR.

    # Set real (absolute) URL (is this only relevant for testing?):
    if ($self->url ne $tx->req->url) {
      push @{$self->redirects}, $self->url;  # for logging?
      $self->url($tx->req->url);
    }
    my @feeds = $self->find_feed_links($result);

    if (@feeds) {
      push @{$self->redirects}, $self->url; # not really a redirect, but save it
      $self->url(shift @feeds);

      # save any remaining feed links as related
      push @{$self->related}, @feeds if (@feeds);
      return $self->_load();
    }
   else {
        # call me crazy, but maybe this is just a feed served as HTML?
        my $test = Mojo::Feed->new( url => $self->url, body => $result->body );
        $test->charset($result->content->charset) if ($result->content->charset);
        if ($test->is_valid) {
          # can't avoid parsing twice;
          # body is probably being called in the dom initializer
          # :(
          # $self->dom($test->dom);
          $self->charset($test->charset) if ($test->charset);
          return $test->body;
        }
        else {
          $self->is_valid(undef);
          croak "No valid feed found at ", $self->url;
        }
   }
  }
}

sub find_feed_links {
  my ($self, $result) = @_;
  my @feeds;

  # Find feed link elements in HEAD:
  my $base
    = Mojo::URL->new(
    $result->dom->find('head base')->map('attr', 'href')->join('') || $self->url)
    ->to_abs($self->url);
  my $title
    = $result->dom->find('head > title')->map('text')->join('') || $self->url;
  $result->dom->find('head link')->each(sub {
    my $attrs = $_->attr();
    return unless ($attrs->{'rel'});
    my %rel = map { $_ => 1 } split /\s+/, lc($attrs->{'rel'});
    my $type = ($attrs->{'type'}) ? lc trim $attrs->{'type'} : undef;
    if ($type && $self->is_feed_content_type($type)
      && ($rel{'alternate'} || $rel{'service.feed'}))
    {
      push @feeds, Mojo::URL->new($attrs->{'href'})->to_abs($base);
    }
  });

  # Find feed links ()
  state $feed_exp = qr/((\.(?:rss|xml|rdf)$)|(\/feed\/*$)|(feeds*\.))/;
  $result->dom->find('a')->grep(sub {
    $_->attr('href') && $_->attr('href') =~ /$feed_exp/io;
  })->each(sub {
    push @feeds, Mojo::URL->new($_->attr('href'))->to_abs($base);
  });
  return @feeds;
}

sub to_hash {
  my $self = shift;
  my $hash = {map { $_ => '' . ($self->$_ || '') } (keys %generic)};
  $hash->{items} = $self->items->map('to_hash')->to_array;
  return $hash;
}

sub to_string {
  my $self = shift;
  foreach my $k (keys %generic) {
    if ($self->$k && $self->$k ne $self->_get_selector($k)) {
      # write it to the DOM:
        $self->_set_selector($k, $self->$k);
    }
  }
  $self->items->each(sub { $_->to_string });  # maybe break this out to a sync method
  $self->dom->to_string;
}

1;
__END__