File Coverage

blib/lib/XML/RSS/Feed.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package XML::RSS::Feed;
use strict;
use warnings;
use XML::RSS;
use XML::RSS::Headline;
use Time::HiRes;
use Storable qw(store retrieve);
use Carp qw(carp);

use constant DEFAULT_DELAY => 3600;

our $VERSION = 2.4;

sub new {
    my ( $class, %args ) = @_;

    my $self = bless {
        process_count       => 0,
        rss_headlines       => [],
        rss_headline_ids    => {},
        max_headlines       => 0,
        init_headlines_seen => 0,
    }, $class;

    foreach my $method ( keys %args ) {
        if ( $self->can($method) ) {
            $self->$method( $args{$method} );
        }
        else {
            carp "Invalid argument '$method'";
        }
    }
    $self->_load_cached_headlines if $self->{tmpdir};
    $self->delay(DEFAULT_DELAY) unless $self->delay;
    return $self;
}

sub _load_cached_headlines {
    my ($self)       = @_;
    my $filename_sto = $self->{tmpdir} . '/' . $self->name . '.sto';
    my $filename_xml = $self->{tmpdir} . '/' . $self->name;
    if ( -s $filename_sto ) {
        my $cached = retrieve($filename_sto);
        my $title = $self->title || $cached->{title} || '';
        $self->set_last_updated( $cached->{last_updated} );
        $self->{process_count}++;
        $self->process( $cached->{items}, $title, $cached->{link} );
        warn "[$self->{name}] Loaded Cached RSS Storable\n" if $self->{debug};
    }
    elsif ( -T $filename_xml ) {    # legacy XML caching
        if ( open( my $fh, '<', $filename_xml ) ) {
            my $xml = do { local $/ = undef, <$fh> };
            close $fh;
            warn "[$self->{name}] Loaded Cached RSS XML\n" if $self->{debug};
            $self->{process_count}++;
            $self->parse($xml);
        }
        else {
            carp "[$self->{name}] Failed to load XML cache $filename_xml\n";
        }
    }
    else {
        warn "[$self->{name}] No Cache File Found\n" if $self->{debug};
    }
    return;
}

sub _strip_whitespace {
    my ($string) = @_;
    $string =~ s/^\s+//;
    $string =~ s/\s+$//;
    return $string;
}

sub _mark_all_headlines_seen {
    my ($self) = @_;
    return unless $self->{process_count} || $self->{init_headlines_seen};
    $self->{rss_headline_ids}{ $_->id } = 1 for $self->late_breaking_news;
    return;
}

sub parse {
    my ( $self, $xml ) = @_;
    my $rss = XML::RSS->new();
    eval { $rss->parse($xml) };
    unless ($@) {
        warn "[$self->{name}] Parsed RSS XML\n" if $self->{debug};
        my $items = [ map { { item => $_ } } @{ $rss->{items} } ];

        $self->process(
            $items,
            ( $self->title || $rss->{channel}{title} ),
            $rss->{channel}{link}
        );

        return 1;
    }
    carp "[$self->{name}] [!!] Failed to parse RSS XML: $@\n";
    return;
}

sub process {
    my ( $self, $items, $title, $link ) = @_;
    return unless $items;
    $self->pre_process;
    $self->process_items($items);
    $self->title($title) if $title;
    $self->link($link)   if $link;
    $self->post_process;
    return 1;
}

sub pre_process {
    my ($self) = @_;
    $self->_mark_all_headlines_seen;
    return;
}

sub process_items {
    my ( $self, $items ) = @_;
    return unless $items;

    # used 'reverse' so order seen is preserved
    for my $item ( reverse @$items ) {
        $self->create_headline(%$item);
    }
    return 1;
}

sub post_process {
    my ($self) = @_;
    if ( $self->init ) {
        warn "[$self->{name}] "
            . $self->late_breaking_news
            . " New Headlines Found\n"
            if $self->{debug};
    }
    else {
        $self->_mark_all_headlines_seen;
        $self->init(1);
        warn "[$self->{name}] "
            . $self->num_headlines
            . " Headlines Initialized\n"
            if $self->{debug};
    }
    $self->{process_count}++;
    $self->cache;
    $self->set_last_updated;
    return;
}

sub create_headline {
    my ( $self, %args ) = @_;
    my $hlobj = $self->{hlobj} || 'XML::RSS::Headline';
    $args{headline_as_id} = $self->{headline_as_id};
    my $headline = $hlobj->new(%args);
    return unless $headline;

    unshift( @{ $self->{rss_headlines} }, $headline )
        unless $self->seen_headline( $headline->id );

    # remove the oldest if the new headline put us over the max_headlines limit
    if ( $self->max_headlines ) {
        while ( $self->num_headlines > $self->max_headlines ) {
            my $garbage = pop @{ $self->{rss_headlines} };

            # just in case max_headlines < number of headlines in the feed
            $self->{rss_headline_ids}{ $garbage->id } = 1;
            warn "[$self->{name}] Exceeded maximum headlines, removing "
                . "oldest headline\n"
                if $self->{debug};
        }
    }
    return;
}

sub num_headlines {
    my ($self) = @_;
    return scalar @{ $self->{rss_headlines} };
}

sub seen_headline {
    my ( $self, $id ) = @_;
    return 1 if exists $self->{rss_headline_ids}{$id};
    return;
}

sub headlines {
    my ($self) = @_;
    return wantarray ? @{ $self->{rss_headlines} } : $self->{rss_headlines};
}

sub late_breaking_news {
    my ($self) = @_;
    my @list = grep { !$self->seen_headline( $_->id ); }
        @{ $self->{rss_headlines} };
    return wantarray ? @list : scalar @list;
}

sub cache {
    my ($self) = @_;
    return unless $self->tmpdir;
    if ( -d $self->tmpdir && $self->num_headlines ) {
        my $tmp_filename = $self->tmpdir . '/' . $self->{name} . '.sto';
        eval { store( $self->_build_dump_structure, $tmp_filename ) };
        if ($@) {
            carp "[$self->{name}] Could not cache RSS XML to $tmp_filename\n";
            return;
        }
        else {
            warn "[$self->{name}] Cached RSS Storable to $tmp_filename\n" if $self->{debug};
            return 1;
        }
    }
    return;
}

sub _build_dump_structure {
    my ($self) = @_;
    my $cached = {};
    $cached->{title}        = $self->title;
    $cached->{link}         = $self->link;
    $cached->{last_updated} = $self->{timestamp_hires};
    $cached->{items}        = [];
    for my $headline ( $self->headlines ) {
        push @{ $cached->{items} }, {
            headline    => $headline->headline,
            url         => $headline->url,
            description => $headline->description,
            first_seen  => $headline->first_seen_hires,
            guid        => $headline->guid,
        };
    }
    return $cached;
}

sub set_last_updated {
    my ( $self, $hires_time ) = @_;
    $self->{hires_timestamp} = $hires_time if $hires_time;
    $self->{hires_timestamp} = Time::HiRes::time()
        unless $self->{hires_timestamp};
    return;
}

sub last_updated {
    my ($self) = @_;
    return int $self->{hires_timestamp};
}

sub last_updated_hires {
    my ($self) = @_;
    return $self->{hires_timestamp};
}

sub title {
    my ( $self, $title ) = @_;
    if ($title) {
        $title = _strip_whitespace($title);
        $self->{title} = $title if $title;
    }
    return $self->{title};
}

sub debug {
    my $self = shift @_;
    $self->{debug} = shift if @_;
    return $self->{debug};
}

sub init {
    my $self = shift @_;
    $self->{init} = shift if @_;
    return $self->{init};
}

sub name {
    my $self = shift;
    $self->{name} = shift if @_;
    return $self->{name};
}

sub delay {
    my $self = shift @_;
    $self->{delay} = shift if @_;
    return $self->{delay};
}

sub link {
    my $self = shift @_;
    $self->{link} = shift if @_;
    return $self->{link};
}

sub url {
    my $self = shift @_;
    $self->{url} = shift if @_;
    return $self->{url};
}

sub headline_as_id {
    my ( $self, $bool ) = @_;
    if ( defined $bool ) {
        $self->{headline_as_id} = $bool;
        $_->headline_as_id($bool) for $self->headlines;
    }
    return $self->{headline_as_id};
}

sub hlobj {
    my ( $self, $hlobj ) = @_;
    $self->{hlobj} = $hlobj if defined $hlobj;
    return $self->{hlobj};
}

sub tmpdir {
    my $self = shift @_;
    $self->{tmpdir} = shift if @_;
    return $self->{tmpdir};
}

sub init_headlines_seen {
    my $self = shift @_;
    $self->{init_headlines_seen} = shift if @_;
    return $self->{init_headlines_seen};
}

sub max_headlines {
    my $self = shift @_;
    $self->{max_headlines} = shift if @_;
    return $self->{max_headlines};
}

sub failed_to_fetch {
    carp __PACKAGE__ . '::failed_to_fetch has been deprecated';
    return;
}

sub failed_to_parse {
    carp __PACKAGE__ . '::failed_to_parse has been deprecated';
    return;
}

1;

__END__