File Coverage

blib/lib/XML/OPDS.pm

Criterion	Covered	Total	%
statement	132	143	92.3
branch	24	34	70.5
condition	3	5	60.0
subroutine	22	23	95.6
pod	10	10	100.0
total	191	215	88.8

package XML::OPDS;

use strict;
use warnings FATAL => 'all';
use Types::Standard qw/Str Object ArrayRef InstanceOf Maybe Int/;
use Moo;
use DateTime;
use DateTime::Format::RFC3339;
use XML::Atom;
use XML::Atom::Feed;
use XML::Atom::Entry;
use XML::OPDS::Navigation;
use XML::OPDS::Acquisition;
use XML::OPDS::OpenSearch::Query;

=head1 NAME

XML::OPDS - OPDS (Open Publication Distribution System) feed creation

=head1 VERSION

Version 0.06

=cut

our $VERSION = '0.06';


=head1 DESCRIPTION

This module facilitates the creation of OPDS feeds.

The specifications can be found at L<http://opds-spec.org/> while the
validator is at L<http://opds-validator.appspot.com/>.

The idea is that it should be enough to pass the navigation links and
the title entries with some data, and have the feed back.

The OPDS feeds are basically Atom feeds, hence this module uses
L<XML::Atom> under the hood.

Some features are not supported yet, but patches are welcome. Also
keep in mind that the applications which are supposed to talk to your
server have a level of support which varies from decent to "keep
crashing".

This is still very much a work in progress, but it's already
generating valid and usable catalogs.

=head1 SYNOPSIS

  use XML::OPDS;
  my $feed = XML::OPDS->new(prefix => 'http://amusewiki.org');
  # add two links, self and start are mandatory.
  $feed->add_to_navigations(
                            rel => 'self',
                            title => 'Root',
                            href => '/',
                           );
  $feed->add_to_navigations(
                            rel => 'start',
                            title => 'Root',
                            href => '/',
                           );
  # add a navigation for the title list, marking as leaf, where the
  # download links can be retrieved.
  $feed->add_to_navigations(
                            title => 'Titles',
                            description => 'texts sorted by title',
                            href => '/titles',
                            acquisition => 1,
                           );
  # and render
  print $feed->render;
  # you can reuse the object for leaf feeds (i.e. the acquistion
  # feeds), pushing another self navigation, which will replace the
  # previous one.
  $feed->add_to_navigations(
                            rel => 'self',
                            title => 'Titles',
                            description => 'texts sorted by title',
                            href => '/titles',

                           );
  # or, implicitely setting the self rel and cleaning the navigation
  # stash, keeping the meta
  $feed->add_to_navigations_new_level(
                                      title => 'Titles',
                                      acquisition => 1,
                                      href => '/titles',
                                     );
  $feed->add_to_acquisitions(
                             href => '/my/title',
                             title => 'My title',
                             files => [ '/my/title.epub' ],
                            );
  # and here we have an acquisition feed, because of the presence of
  # the acquisition.
  print $feed->render;

=head1 ENCODING

Even if the module wants characters as input (decoded strings, not
bytes), the output XML is an UTF-8 encoded string.

=head1 SETTERS/ACCESSORS

=head2 navigations

Arrayref of L<XML::OPDS::Navigation> objects. An object with a rel
C<self> (the feed itself) and one with the rel C<start> (the root
feed) are mandatory. If not present, the module will crash while
rendering the feed.

=head2 acquisitions

Arrayref of L<XML::OPDS::Acquisition> objects. If one or more objects
are present, the feed will become an acquistion feed.

=head2 author

The producer of the feed. Defaults to this class name and version.

=head2 author_uri

The uri of the author. Defaults to L<http://amusewiki.org> (which is
the home of this class).

=head2 prefix

Default to the empty string. On instances of this class, by itself has
no effect. However, when calling C<add_to_acquisitions> and
C<add_to_navigations>, it will be passed to the constructors of those
objects.

This is usually the hostname of the OPDS server. So you need just to
pass, e.g. 'http://amusewiki.org' and have all the links prefixed by
that (no slash mangling or adding is performed). If you are going to
pass the full urls, leave it at the default.

=head2 updated

Default to current timestamp. When calling C<create_navigation> or
C<create_acquistion>, use this timestamp as default.

=head2 logo

The feed logo. If prefix is set, prepend it.

=head2 icon

The feed icon. If prefix is set, prepend it.

=head1 METHODS

=head2 render

Return the generated xml.

=head2 atom

Return the L<XML::Atom::Feed> object.

=head2 create_navigation(%args)

Create a L<XML::OPDS::Navigation> object inheriting the prefix.

=head2 create_acquisition(%args)

Create a L<XML::OPDS::Acquisition> object inheriting the prefix.

=head2 add_to_navigations(%args)

Call C<create_navigation> and add it to the C<navigations> stack.

=head2 add_to_navigations_new_level(%args)

Like C<add_to_navigations>, but it's meant to be used for
C<rel:self> elements.

The C<rel:self> attribute is injected in the arguments which are
passed to C<create_navigation>.

If a navigation with the attribute C<rel> set to C<self> was already
present in the stack, the new one will become the new C<self>, while
the old one will become an C<up> rel.

Also, this will remove any existing navigation with the C<rel>
attribute set to C<subsection>, given that you are creating a new
level.

This is designed to play well with chained actions (so you can reuse
the object, stack selfs, and the result will be correct).

=head2 add_to_acquisitions(%args)

Call C<create_acquisition> and add it to the C<acquisition> stack.

=head1 INTERNAL METHODS

=head2 navigation_entries

Return a list of L<XML::OPDS::Navigation> objects excluding unique
relationships like C<self>, C<start>, C<up>, C<previous>, C<next>,
C<first>, C<last>.

=head2 navigation_hash

Return an hashref, where the keys are the C<rel> attributes of the
navigation objects. The value is an object if the navigation is meant
to be unique, or an arrayref of objects if not so.

=head2 is_acquisition

Return true if there are acquisition objects stacked.

=cut

has navigations => (is => 'rw',
                    isa => ArrayRef[InstanceOf['XML::OPDS::Navigation']],
                    default => sub { [] });
has acquisitions => (is => 'rw',
                     isa => ArrayRef[InstanceOf['XML::OPDS::Acquisition']],
                     default => sub { [] });
has author => (is => 'rw', isa => Str, default => sub { __PACKAGE__ . ' ' . $VERSION });
has author_uri => (is => 'rw', isa => Str, default => sub { 'http://amusewiki.org' });
has prefix => (is => 'rw', isa => Str, default => sub { '' });
has updated => (is => 'rw', isa => Object, default => sub { DateTime->now });
has icon => (is => 'rw', isa => Str, default => sub { '' });
has logo => (is => 'rw', isa => Str, default => sub { '' });

has _dt_formatter => (is => 'ro', isa => Object,
                      default => sub { DateTime::Format::RFC3339->new });
has _fh => (is => 'ro',
            isa => Object,
            default => sub {
                XML::Atom::Namespace->new(fh => 'http://purl.org/syndication/history/1.0');
            });

# opensearch accessors

has _os => (is => 'ro',
            isa => Object,
            default => sub {
                XML::Atom::Namespace->new(opensearch => 'http://a9.com/-/spec/opensearch/1.1/');
            });


=head1 OPENSEARCH RESULTS

The following attributes can be set if you are building an Atom
response for OpenSearch. See L<XML::OPDS::OpenSearch::Query> for a
concrete example.

=head2 search_result_pager

A L<Data::Page> object with the specification of the pages.

=head2 search_result_terms

A string with the query for which you are serving the results.

=head2 search_result_queries

Additional Query elements, should be an arrayref of
L<XML::OPDS::OpenSearch::Query> objects.

=cut

has search_result_pager => (is => 'rw',
                            isa => InstanceOf['Data::Page']);

has search_result_terms => (is => 'rw',
                            isa => Str);

has search_result_queries => (is => 'rw',
                              isa => ArrayRef[InstanceOf['XML::OPDS::OpenSearch::Query']],
                              default => sub { [] },
                             );

sub navigation_entries {
    my $self = shift;
    my $hash = $self->navigation_hash;
    my @others;
    foreach my $k (sort keys %$hash) {
        my $entries = $hash->{$k};
        # exclude the uniques
        if (ref($entries) eq 'ARRAY') {
            push @others, @$entries;
        }
    }
    return @others;
}

sub navigation_hash {
    my $self = shift;
    my $navs = $self->navigations;
    die "Missing navigations" unless $navs && @$navs;
    my %out;
    my %uniques = (
                   start => 1,
                   self => 1,
                   up => 1,
                   next => 1,
                   previous => 1,
                   first => 1,
                   last => 1,
                   search => 1,
                   crawlable => 1,
                  );
    foreach my $nav (@$navs) {
        my $rel = $nav->rel;
        # uniques
        if ($uniques{$rel}) {
            $out{$rel} = $nav;
        }
        else {
            $out{$rel} ||= [];
            push @{$out{$rel}}, $nav;
        }
    }
    return \%out;
}

sub is_acquisition {
    if (my $acquisitions = shift->acquisitions) {
        return scalar(@$acquisitions);
    }
    else {
        return 0;
    }
}

sub _is_paged {
    my $self = shift;
    my $partial = 0;
    foreach my $nav (@{$self->navigations}) {
        if ($nav->rel =~ m/\A(next|previous|first|last)\z/) {
            $partial = 1;
            last;
        }
    }
    return $partial;
}

sub atom {
    my $self = shift;
    my $feed = XML::Atom::Feed->new(Version => 1.0);
    my $navs = $self->navigation_hash;
    my $main = delete $navs->{self};
    die "Missing self navigation element!" unless $main;
    $feed->id($main->identifier);
    $feed->add_link($main->as_link);
    my @nav_entries;
    foreach my $rel (sort keys %$navs) {
        # use only the unique
        my $nav = delete $navs->{$rel};
        if (ref($nav) eq 'ARRAY') {
            push @nav_entries, @$nav;
        }
        else {
            $feed->add_link($nav->as_link);
        }
    }
    $feed->title($main->title);
    $feed->updated($self->_dt_formatter->format_datetime($main->updated));
    if (my $icon = $self->icon) {
        $feed->icon($self->prefix . $icon);
    }
    if (my $logo = $self->logo) {
        $feed->logo($self->prefix . $logo);
    }
    if (my $author_name = $self->author) {
        my $author = XML::Atom::Person->new(Version => 1.0);
        $author->name($author_name);
        if (my $author_uri = $self->author_uri) {
            $author->uri($author_uri);
        }
        $feed->author($author);
    }

    # opensearch element
    # http://www.opensearch.org/Specifications/OpenSearch/1.1#OpenSearch_response_elements
    if (my $pager = $self->search_result_pager) {
        $feed->set($self->_os, totalResults =>  $pager->total_entries);
        $feed->set($self->_os, startIndex => $pager->first);
        $feed->set($self->_os, itemsPerPage => $pager->entries_per_page);
        if (my $term = $self->search_result_terms) {
            my $query = XML::OPDS::OpenSearch::Query->new(
                                                          role => 'request',
                                                          searchTerms => $term,
                                                         );
            $feed->add($self->_os, Query => undef, $query->attributes_hashref);
        }
    }
    foreach my $query (@{ $self->search_result_queries }) {
        $feed->add($self->_os, Query => undef, $query->attributes_hashref);
    }
    if ($self->is_acquisition) {
        # if it's an acquisition feed, stuff the links in the feed,
        # but filter out the subsections. And probably other stuff as well.
        foreach my $link (@nav_entries) {
            my %rels = (related => 1, alternate => 1);
            $feed->add_link($link->as_link) if $rels{$link->rel};
        }
        unless ($self->_is_paged) {
            $feed->set($self->_fh, complete => undef);
        }
        foreach my $entry (@{$self->acquisitions}) {
            $feed->add_entry($entry->as_entry);
        }
    }
    else {
        # othewise use the links to create entries
        foreach my $entry (@nav_entries) {
            $feed->add_entry($entry->as_entry);
        }
    }
    return $feed;
}

sub render {
    shift->atom->as_xml;
}

sub create_navigation {
    my $self = shift;
    return XML::OPDS::Navigation->new(prefix => $self->prefix,
                                      updated => $self->updated,
                                      @_);
}

sub add_to_navigations {
    my $self = shift;
    my $navigation = $self->create_navigation(@_);
    push @{$self->navigations}, $navigation;
    return $navigation;
}

sub add_to_navigations_new_level {
    my $self = shift;
    my $navigation = $self->create_navigation(rel => 'self', @_);
    # turn the previous self in an "up" link.
    if ($navigation->rel eq 'self') {
        # new level, so remove the subsections
        my @existing = grep { $_->rel ne 'subsection' } @{$self->navigations};
        # promote the existing self to "up"
        foreach my $previous (grep { $_->rel eq 'self' } @existing) {
            $previous->rel('up');
        }
        # reset
        $self->navigations(\@existing);
    }
    push @{$self->navigations}, $navigation;
    return $navigation;
}

sub create_acquisition {
    my $self = shift;
    return XML::OPDS::Acquisition->new(prefix => $self->prefix,
                                       updated => $self->updated,
                                       @_);
}

sub add_to_acquisitions {
    my $self = shift;
    my $acquisition = $self->create_acquisition(@_);
    push @{$self->acquisitions}, $acquisition;
    return $acquisition;
}


=head1 AUTHOR

Marco Pessotto, C<< <melmothx at gmail.com> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-xml-opds at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=XML-OPDS>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc XML::OPDS


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=XML-OPDS>

=item * MetaCPAN

L<http://metacpan.org/pod/XML::OPDS>

=back

=head1 LICENSE AND COPYRIGHT

Copyright 2016 Marco Pessotto.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See L<http://dev.perl.org/licenses/> for more information.


=cut

1; # End of XML::OPDS