File Coverage

blib/lib/XML/Grammar/ProductsSyndication.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

package XML::Grammar::ProductsSyndication;

use warnings;
use strict;

use 5.008;

use File::Spec;

use XML::Grammar::ProductsSyndication::ConfigData;

use XML::LibXML;
use XML::LibXSLT;
use XML::Amazon;
use LWP::UserAgent;
use Imager;

use base 'Class::Accessor';

__PACKAGE__->mk_accessors(qw(
    _data_dir
    _filename
    _img_fn
    _source_dom
    _stylesheet
    _xml_parser
));

=head1 NAME

XML::Grammar::ProductsSyndication - an XML Grammar for ProductsSyndication.

=head1 VERSION

Version 0.0403

=cut

our $VERSION = '0.0403';

=head1 SYNOPSIS

    use XML::Grammar::ProductsSyndication;

    my $synd =
        XML::Grammar::ProductsSyndication->new(
            {
                'source' =>
                {
                    'file' => "products.xml",
                },
            }
        );

    # A LibXML compatible XHTML DOM
    my $xhtml = $synd->transform_into_html({ 'output' => "xml" });

    # Not implemented yet!
    $synd->download_preview_images(
        {
            'dir' => "mydir/",
        }
        );

=head1 FUNCTIONS

=head2 XML::Grammar::ProductsSyndication->new({ arg1 => "value"...})

The constructor - accepts a single hash reference with the following keys:

=over 4

=item 'source'

A reference to a hash that contains the information for the source XML for the
file. Currently supported is a C<'file'> key that contains a path to the file.

=item 'data_dir'

Points to the data directory where the DTD files, the XSLT stylesheet, etc.
are stored. Should not be generally over-ridden.

=back

=cut

sub new
{
    my $class = shift;
    my $self = {};
    bless $self, $class;
    $self->_init(@_);
    return $self;
}

sub _init
{
    my ($self, $args) = @_;

    my $source = $args->{'source'} or
        die "did not specify the source";

    my $file = $source->{file};

    $self->_filename($file);

    my $data_dir = $args->{'data_dir'} ||
        XML::Grammar::ProductsSyndication::ConfigData->config('extradata_install_path')->[0];

    $self->_data_dir($data_dir);
    return 0;
}

sub _get_xml_parser
{
    my $self = shift;

    if (!defined($self->_xml_parser()))
    {
        $self->_xml_parser(XML::LibXML->new());
        $self->_xml_parser()->validation(0);
    }
    return $self->_xml_parser();
}

sub _get_source_dom
{
    my $self = shift;

    if (!defined($self->_source_dom()))
    {
        $self->_source_dom($self->_get_xml_parser()->parse_file($self->_filename()));
    }
    return $self->_source_dom();
}

=head2 $processor->is_valid()

Checks if the filename validates according to the DTD.

=cut

sub is_valid
{
    my $self = shift;

    my $dtd =
        XML::LibXML::Dtd->new(
            "Products Syndication Markup Language 0.1.1",
            File::Spec->catfile(
                $self->_data_dir(),
                "product-syndication.dtd"
            ),
        );

    return $self->_get_source_dom()->validate($dtd);
}

sub _get_stylesheet
{
    my $self = shift;

    if (!defined($self->_stylesheet()))
    {
        my $xslt = XML::LibXSLT->new();

        my $style_doc = $self->_get_xml_parser()->parse_file(
                File::Spec->catfile(
                    $self->_data_dir(),
                    "product-syndication.xslt"
                ),
            );

        $self->_stylesheet($xslt->parse_stylesheet($style_doc));
    }
    return $self->_stylesheet();
}

=head2 $processor->transform_into_html({ 'output' => $output, })

Transforms the output into HTML, and returns the results. If C<'output'> is
C<'xml'> returns the L XML DOM. If C<'output'> is C<'string'>
returns the XML as a monolithic string. Other C<'output'> formats are
undefined.

=cut

sub transform_into_html
{
    my ($self, $args) = @_;

    my $source_dom = $self->_get_source_dom();
    my $stylesheet = $self->_get_stylesheet();

    my $results = $stylesheet->transform($source_dom);

    my $medium = $args->{output};

    if ($medium eq "string")
    {
        return $stylesheet->output_string($results);
    }
    elsif ($medium eq "xml")
    {
        return $results;
    }
    else
    {
        die "Unknown medium";
    }
}

=head2 $self->update_cover_images({...});

Updates the cover images from Amazon. Receives one hash ref being the
arguments. Valid keys are:

=over 4

=item * size

The request size of the image - C<'s'>, C<'m'>, C<'l'>,

=item * resize_to

An optional hash ref containing width and height maximal dimensions of the
image to clip to.

=item * name_cb

A callback to determine the fully qualified path of the file. Receives the
following information:

=over 4

=item * xml_node

=item * id

=item * isbn

=back

=item * amazon_token

An Amazon.com web services token. See L.

=item * amazon_associate

An optional Amazon.com associate ID. See L.

=item * amazon_sak

An optional Amazon.com Secret Access Key (sak). See L.

=item * overwrite

If true, instructs to overwrite the files in case they exist.

=back

=cut

sub _transform_image
{
    my ($self, $args) = @_;

    my $content = $args->{content};
    my $resize_to = $args->{resize_to};

    if (!defined($resize_to))
    {
        return $content;
    }
    else
    {
        my ($req_w, $req_h) = @{$resize_to}{qw(width height)};

        my $image = Imager->new();
        $image->read(data => $content, type => "jpeg");

        $image = $image->scale(xpixels => $req_w, ypixels => $req_h, type => 'min');

        my $buffer = "";
        $image->write (data => \$buffer, type => "jpeg");

        return $buffer;
    }
}

sub _get_not_available_cover_image_data
{
    my $self = shift;
    open my $in, "<", File::Spec->catfile($self->_data_dir(), "na-cover.jpg");
    my $content = "";
    local $/;
    $content = <$in>;
    close($in);
    return $content;
}

sub _write_image
{
    my ($self, $contents) = @_;

    my $filename = $self->_img_fn();

    open my $out, ">", $filename
        or die "Could not open file '$filename'";
    print {$out} $contents;
    close ($out);
}

sub update_cover_images
{
    my ($self, $args) = @_;

    my $size = $args->{size};
    my $name_cb = $args->{name_cb};
    my $overwrite = $args->{overwrite};

    my $amazon_token = $args->{amazon_token};
    my @amazon_associate =
        (
            (exists($args->{amazon_associate}) ?
                (associate => $args->{amazon_associate},) :
                ()
            ),
            (exists($args->{amazon_sak}) ?
                (sak => $args->{amazon_sak},) :
                (),
            ),
        );

    my $dom = $self->_get_source_dom();

    my @products = $dom->findnodes('//prod');

    my $amazon =
        XML::Amazon->new(
            token => $amazon_token,
            @amazon_associate,
        );

    my $ua = LWP::UserAgent->new();

    PROD_LOOP:
    foreach my $prod (@products)
    {
        my ($asin_node) = $prod->findnodes('isbn');

        my $disable = $asin_node->getAttribute("disable");
        if (defined($disable) && ($disable eq "1"))
        {
            next PROD_LOOP;
        }

        my $asin = $asin_node->textContent();

        $self->_img_fn(
            $name_cb->(
                {
                    'xml_node' => $prod,
                    'id' => $prod->getAttribute("id"),
                    'isbn' => $asin,
                }
            )
        );

        if ($overwrite || (! -e $self->_img_fn()))
        {
            my $item = $amazon->asin($asin);

            my $image_url = $item->image($size);
            if (!defined($image_url))
            {
                $self->_write_image(
                    $self->_transform_image(
                        {
                            %$args,
                            'content' =>
                                $self->_get_not_available_cover_image_data(),
                        }
                    )
                );
            }
            else
            {
                my $response = $ua->get($image_url);
                if ($response->is_success)
                {
                    $self->_write_image(
                        $self->_transform_image(
                            {
                                %$args,
                                'content' => $response->content(),
                            },
                        ),
                    );
                }
                else
                {
                    die $response->status_line();
                }
            }
        }
    }
}

=head1 AUTHOR

Shlomi Fish, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to
C, or through the web interface at
L.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.

=head1 TODO

=over 4

=item * Automatically Download Preview Images from Amazon.com

=back

=head1 SUPPORT

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

    perldoc XML::Grammar::ProductsSyndication

You can also look for information at:

=over 4

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * RT: CPAN's request tracker

L

=item * Search CPAN

L

=back

=head1 ACKNOWLEDGEMENTS

* L for their excellent XSLT Tutorial.

* L for squashing some L bugs
I reported to him.

=head1 TODO

=over 4

=item * Trace the progress of the Amazon.com progress.

=item * More XSLT customisation.

=item * Generate a table-of-contents.

=back

=head1 COPYRIGHT & LICENSE

Copyright 2006 Shlomi Fish, all rights reserved.

This program is released under the following license: MIT X11.

=cut

1; # End of XML::Grammar::ProductsSyndication