File Coverage

blib/lib/RSSycklr.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package RSSycklr;
use Mouse;
no warnings "uninitialized";
use Carp ( qw/ carp confess croak / );
use YAML ();
use XML::Feed ();
use HTML::Truncate ();
use HTML::TokeParser::Simple ();
use XML::LibXML ();
use DateTime ();
use Scalar::Util "blessed";
use URI ();
use File::ShareDir ();
use Hash::Merge::Simple "merge";
use File::Spec;
use Encode;
use Capture::Tiny "capture";

our $VERSION = "0.15";

has "keep_tags" =>
    is => "rw",
    isa => "HashRef",
    default => sub {
        return { map {; $_ => 1 } qw( del ins i u b em
                                      strong abbr br img dfn
                                      acronym q sub sup cite
                                      code kbd samp strong var
                                      strike s tt a )
               };
    },
    ;

has "debug" =>
    is => "rw",
    isa => "Bool",
    default => sub { 0 },
    ;

has "tt2" =>
    is => "ro",
    lazy => 1, # not always used
    isa => "Template",
    default => sub {
        require Template;
        Template->new({
                       ENCODING => 'UTF-8',
                       DEFAULT_ENCODING => 'UTF-8',
                      });
    },
    handles => [qw( process )],
    ;

# No type so it can take any Template takes
has "template" =>
    is => "rw",
    lazy => 1, # not always used
    default => sub { \<<"TT_TEMPLATE";

[%-FOR feed IN rssycklr.feeds() %]
[%-NEXT UNLESS feed.count %]

    <[% feed_title_tag || "h4" %]>
      [%-FILTER html; feed.title_override || feed.title; END %]

  [%~IF feed.entries.0.lede %]

      [%-FOR entry IN feed.entries %]
      [%-entry.title | html %]

      [% entry.lede %]
        [% modified = entry.modified ? entry.modified : entry.feed.modified %]
[% modified.ymd(".") %] [% modified.hour_12 %]:[% modified.min | format('%02d') %][% modified.am_or_pm %]


      [%~END %]

    [%~ELSE %]

    [%-FOR entry IN feed.entries %]
      [%-entry.title | html %]
    [%~END %]

  [%~END %]

[%~END %]

TT_TEMPLATE
                 },
    ;

has "xml_parser" =>
    is => "rw",
    isa => "XML::LibXML",
    default => sub {
        my $libxml = XML::LibXML->new();
        $libxml->keep_blanks(1);
        $libxml->line_numbers(1);
        $libxml->complete_attributes(1);
        $libxml->clean_namespaces(1);
        $libxml->no_network(1);
        $libxml->recover_silently(1);
        return $libxml;
    },
    handles => [qw( parse_html_string )],
    ;

has "dtd" =>
    is => "rw",
    isa => "XML::LibXML::Dtd",
    ;

has "truncater" =>
    is => "rw",
    isa => "Object", # "HTML::Truncate",
    default => sub {
        HTML::Truncate->new(repair => 1,
                            on_space => 1,
                            chars => 170);
    },
    handles => [ qw( truncate ) ],
    ;

has "feeds" =>
    is => "ro",
    auto_deref => 1,
    isa => "ArrayRef",
    default => sub { [] },
    ;

before "feeds" => sub {
    my $self = shift;
    while ( my $feed = $self->next() )
    {
        push @{$self->{feeds}}, $feed;
    }
};

sub BUILD {
    my ( $self, $args ) = @_;
    $self->config(delete $args->{config}) if $args->{config};
    $self->load_config(delete $args->{load_config}) if $args->{load_config};
}

sub config {
    my $self = shift;
    $self->{_config} ||= $self->_default_config();
    my $hash = shift || return $self->{_config};
    $self->{_config} = merge $self->{_config}, $hash;
    return $self->{_config};
}

sub load_config {
    my $self = shift;
    my $src = shift || return;
    my $info = ref($src) ?
        $src : $src !~ /\n/ ?
        YAML::LoadFile($src) : YAML::Load($src);

    my $feeds = delete $info->{feeds} || [];
    $self->config($info);
    $self->add_feeds($feeds);
    return $self;
}

sub add_feeds {
    my $self = shift;
    my $feeds = shift;
    my $old = scalar @{$self->config->{feeds} || []};
    my $new = scalar @{$feeds};
    for my $info ( @{$feeds} )
    {
        confess "URI is missing from feed data for feed: ", YAML::Dump($info)
            unless $info->{uri};
        push @{$self->config->{feeds}}, $info;
    }
    return ( $old + $new ) == @{$self->config->{feeds}};
}

sub as_string {
    my $self = shift;
    my $out = "";
    $self->process($self->template, { rssycklr => $self }, \$out)
        or confess $self->tt2->error();

    if ( defined wantarray )
    {
        return $out;
    }
    else
    {
        print $out;
        return 1;
    }
}

sub next {
    my $self = shift;
    if ( $self->_maxed_out )
    {
        $self->config->{feeds} = [];
        return;
    }
    my $info = shift @{ $self->config->{feeds} } || return;

    my $uri = blessed($info->{uri}) eq "URI" ?
        $info->{uri} : URI->new($info->{uri});

    my $xml_feed;
    my $ok = eval {
        local $SIG{ALRM} = sub { die "Feed request timeout: $uri\n" };
        alarm( $info->{timeout} || $self->config->{timeout} || 10 );
        $xml_feed = XML::Feed->parse($uri)
            or croak("Could not parse $uri, ", XML::Feed->errstr);
        alarm(0);
        1;
    };
    alarm(0); # Racing parsing fatals can happen in the XML::Feed space(?).
    unless ( $ok == 1 )
    {
        carp $@ || ( "Unknown error parsing " . $info->{uri} )
            if $self->debug;
        return $self->next;
    }

    my $hours_back = DateTime
        ->now( time_zone => 'floating' )
        ->subtract( hours => $info->{hours_back} || $self->config->{hours_back} || 170 );

    if ( $xml_feed->modified )
    {
        return $self->next unless 1 == DateTime->compare( $xml_feed->modified, $hours_back );
    }

    my $max_display    = $info->{max_display} || $self->config->{max_display} || 10;
    my $excerpt_length = $info->{excerpt_length} || $self->config->{excerpt_length};
    my $title_only     = exists($info->{title_only}) ?
        $info->{title_only} # might be undef on purpose to override self->config setting
        :
        $self->config->{title_only};

    my @entry;
  ENTRY:
    for my $entry ( $xml_feed->entries )
    {
        next ENTRY unless $entry->issued;
        next ENTRY unless 1 == DateTime->compare( $entry->issued, $hours_back );

        my %entry;
        unless ( $title_only )
        {
            next ENTRY if $entry->content->body !~ /\S/;
            my $xhtml = $self->html_to_dom( $entry->content->body )
                or die "Couldn't parse ", $entry->content->body;
            $self->_strip_attributes($xhtml);
            $self->_strip_tags($xhtml);
            $self->_handle_images($xhtml, $entry);

            my ( $body ) = $xhtml->findnodes("body");
            unless ( $xhtml->findnodes("head") )
            {
                my $head = $xhtml->createElement("head");
                my $title = $xhtml->createElement("title");
                my $text = $xhtml->createTextNode(__PACKAGE__ . "/" . $VERSION);
                $title->appendChild($text);
                $head->appendChild($title);
                $xhtml->insertBefore($head,$body);
            }

            # Cache it.
            unless ( $self->dtd )
            {
                $self->config->{dtd} ||= "xhtml1-transitional.dtd";
                my $dtd_file = File::ShareDir::dist_file(__PACKAGE__,
                                                         $self->config->{dtd});
                $/ = undef;
                open my $fh, "<", $dtd_file or croak "Couldn't open '$dtd_file' for reading: $!";
                $self->{ $self->config->{dtd} } = <$fh>;
                close $fh or carp "Trouble closing '$dtd_file': $!";
                $self->dtd( XML::LibXML::Dtd->parse_string($self->{ $self->config->{dtd} }) );
            }

            unless ( eval { $xhtml->validate($self->dtd); 1; } )
            {
                carp $@ || "Uknown error",
                    " - parsing content of '", $entry->title,
                    "' from ", $xml_feed->link;
                next ENTRY;
            }

            my $content = "";
            $content .= $_->serialize(1) for $body->childNodes();
            my $more = join("",
                            decode_utf8($self->config->{ellipsis}),
                            '
296
                            $entry->link,
                            '">',
                            decode_utf8($self->config->{read_more}),
                            ''
                            );
            my $output = $self->truncate( $content,
                                          $excerpt_length,
                                          $more );
            $output =~ s/\s\s+/ /g;
            $entry{lede} = $output;
        }
        $entry{xml_feed_entry} = $entry;
        $entry{feed} = $xml_feed;
        push @entry, \%entry;
        last ENTRY if @entry >= $max_display;
    }

    return $self->next unless @entry;

    my $feed = RSSycklr::Feed->new( %{$info},
                                    ellipsis => $self->config->{ellipsis}, # not sure, weak ref to parent instead?
                                    xml_feed => $xml_feed, );

    $feed->{entries} = [ map { $_->{feed} = $feed; RSSycklr::Feed::Entry->new($_) } @entry ];

    $self->{_feeds_returned}++;
    return $feed;
}

sub html_to_dom {
    my $self = shift;
    my $html = shift || return;
    my $renew = "";
    my $p = HTML::TokeParser::Simple->new(\$html);
    no warnings "uninitialized";
    while ( my $token = $p->get_token )
    {
        if ( $token->is_text
             or not $HTML::Tagset::isKnown{ $token->get_tag } )
        {
            my $txt = HTML::Entities::decode_entities($token->as_is);
            $txt =~ s/[^[:print:]]+/ /g; # kill unprintables for a space.
            $renew .= $txt;
        }
        elsif ( $token->get_tag =~ /\Abr\b/i )
        {
            $renew .= "\n";
        }
        elsif ( $HTML::Tagset::canTighten{ $token->get_tag } )
        {
            # Replace block-like tags with \n if we have content
            # already and not more than twice consecutively.
            $renew .= $token->as_is;
        }
        else
        {
            $renew .= $token->as_is;
        }
    }

    # XML::LibXML is noisy even with recover_silently, so-
    my $dom;
    my ( $out, $err ) = capture {
        $dom = $self->parse_html_string(<<"HTML");
Untitled$renew
HTML
    };
    $dom;
}

sub _maxed_out {
    my $self = shift;
    if ( $self->config->{max_feeds}
         and
         $self->config->{max_feeds} <= $self->{_feeds_returned} )
    {
        return 1;
    }
    return;
}

sub _strip_attributes {
    my ( $self, $root ) = @_;

    for my $node ( $root->findnodes("//*") )
    {
        for my $attr ( $node->attributes )
        {
            next if $node->nodeName eq 'a' and $attr->name eq 'href';
            next if $node->nodeName eq 'img' and $attr->name eq 'src';

            next if $attr->name eq 'title'
                and $node->nodeName =~ /\A(?:acronym|abbr|dfn|a)\z/;

            $node->removeAttribute($attr->name);
        }
    }
}

sub _handle_images {
    my ( $self, $root, $entry ) = @_;

    for my $node ( $root->findnodes("//img") )
    {
        if ( $node->getAttribute("src") !~ m,\Ahttp://, )
        {
            $node->parentNode->removeChild($node);
            return;
        }
        # Don't put a link on images that already have one.
        next if $node->parentNode->tagName eq "a";

        my $link = $node->getOwner->createElement("a");
        $link->setAttribute("href", $entry->link);
        $link->setAttribute("title", $entry->title);
        $node->setAttribute("alt", $entry->title);
        $link->appendChild( $node->cloneNode );
        $node->parentNode->replaceChild( $link, $node );
        return 1; # Just do one for now.
    }
}

sub _strip_tags {
    my ( $self, $root ) = @_;

    my $doc = $root->getOwnerDocument;
    my $keep = $self->keep_tags;

    # Special case, we must have this and don't want it mucking the interface.
    $keep->{body} = 1;

    my @nodes = $root->findnodes("//*");
    for my $node ( @nodes )
    {
        next unless $node;
        next if $keep->{$node->nodeName};

        my $frag = $doc->createDocumentFragment();

        for my $n ( $node->childNodes )
        {
            $frag->appendChild($n);
        }
        $node->replaceNode($frag);
    }

    return 1 unless $keep->{br};

    my @outer = $root->findnodes("body/*");

  FORWARD:
    for my $br ( @outer ) {
        last FORWARD unless $br and $br->tagName eq "br";
        $br->parentNode->removeChild($br);
    }

  BACKWARD:
    for my $br ( reverse @outer ) {
        last BACKWARD unless $br and $br->tagName eq "br";
        $br->parentNode->removeChild($br);
    }
    return 1;
}

sub _default_config {
    return {
        excerpt_length => 150,
        ellipsis => "\x{2026}", # chr(8230),
        read_more => "[more]",
        title_only  => undef,
        hours_back  => 72,
        max_feeds   => 10,
#        max_entries => 10,
        max_display => 3,
        timeout => 30,
        css_class => "rssycklr",
#        title_length => undef,
#        excerpt_style => dl|p|br|ul
#        title_style => ul|p|br      # not implemented, ul/li happens now
#        max_images => 1             # this is hardcoded for now
        feed_title_tag => "h4",
        dtd => "xhtml1-transitional.dtd",
    };
}

__PACKAGE__->meta->make_immutable();

package RSSycklr::Feed;
use Mouse;
use HTML::Entities qw( decode_entities );
use Encode qw( decode_utf8 );

has "xml_feed" =>
    is => "ro",
    required => 1,
    isa => "Object",
    handles => [qw( tagline link copyright modified
                    author generator language )],
    ;

has "entries" =>
    is => "ro",
    lazy => 1,
    default => sub { [] },
    required => 1,
    auto_deref => 1,
    isa => "ArrayRef",
    ;

has "title_override" =>
    is => "ro",
    isa => "Str",
    default => sub { "" },
    ;

sub count {
    scalar @{+shift->entries};
}

sub title {
    my $self = shift;
    return $self->{_title} if $self->{_title};
    # Try to guarantee it doesn't return entities.
    $self->{_title} = decode_entities(decode_entities($self->xml_feed->title));
    $self->{_title} = decode_utf8( $self->{_title} );
}

__PACKAGE__->meta->make_immutable();

package RSSycklr::Feed::Entry;
use Mouse;
use DateTime;

has "xml_feed_entry" => ( is => "ro",
                          required => 1,
                          isa => "Object", # ::Atom/RSS
                          handles => [qw( title link content category id author issued modified )],
                        );

has "lede" => ( is => "ro",
                isa => "Str",
                default => sub { "" },
              );

has "feed" => ( is => "ro",
                weak_ref => 1,
                isa => "RSSycklr::Feed",
              );

__PACKAGE__->meta->make_immutable();

1;

__END__