File Coverage

blib/lib/WebService/Bluga/Webthumb.pm

Criterion	Covered	Total	%
statement	24	66	36.3
branch	0	30	0.0
condition	0	11	0.0
subroutine	8	13	61.5
pod	3	3	100.0
total	35	123	28.4

package WebService::Bluga::Webthumb;

use warnings;
use strict;
use Carp;
use Digest::MD5;
use LWP::Simple;
use URI;
use Path::Class;
use POSIX qw(strftime);

=head1 NAME

WebService::Bluga::Webthumb - fetch website thumbnails via webthumb.bluga.net

=cut

our $VERSION = '0.05';

=head1 SYNOPSIS

    use WebService::Bluga::Webthumb;
    my $wt = WebService::Bluga::Webthumb->new(
        user    => $user_id,
        api_key => $api_key,
        size    => $size,  # small, medium, medium2, large (default: medium)
        cache   => $cache_days, # optional - default 14

        # optional settings for local caching:
        cache_dir => '....',
        cache_url_stub => '/images/thumbs/',
    );

    # get a thumbnail URL using the default settings
    my $thumb_url = wt->thumb_url($url);

    # Get a thumbnail URL overriding some settings:
    my $thumb_url = $wt->thumb_url($url, { size => 'large' });



=head1 Class methods

=over 4

=item new

Create a new WebService::Bluga::Webthumb object.  Takes the following params:

=over 4

=item user

Your webthumb user ID, available from your L
page.

=item api_key

Your webthumb API key. also available from your user page.  (This is used to
construct the hash of the thumbnail URL, but not sent directly.)

=item size

The size of the thumbnail to generate.  Size can be:

=over 4

=item * small - 80x60

=item * medium - 160x120

=item * medium2 - 320x240

=item * large - 640x480

=back


=item cache

How many days a generated thumbnail can be cached on the webthumb servers before
a fresh one is generated.  Generating a thumbnail uses a credit whereas serving
up a cached one uses a fraction of a credit, so don't set this too low.

If not specified, defaults to 14 days.

=item cache_dir

If set, generated thumbnails will be saved into this directory, and the URL
returned will be constructed using C (so the C
setting should be set to the URL at which the contents of C are
available).

The age of the cached thumbnail will be compared against the C setting,
and if it's too old, the cached thumbnail will be replaced with a fresh one.

=back

=cut

sub new {
    my $class = shift;
    if (@_ % 2 != 0) {
        croak "Uneven number of parameters provided";
    }

    my %params = @_;

    # TODO: more extensive validation
    if (!$params{user} || !$params{api_key}) {
        croak "'user' and 'api_key' params must be provided";
    }

    if (exists $params{size}
        && !grep { $params{size} eq $_ } qw(small medium medium2 large)
    ) {
        croak "Invalid size $params{size} supplied!";
    } elsif (!exists $params{size}) {
        $params{size} = 'medium';
    }

    if (!exists $params{cache}) {
        $params{cache} = 14;
    }

    my $self = \%params;
    bless $self => $class;
    return $self;
}

=back

=head1 Instance methods

=over 4

=item thumb_url

Given an URL, and optionally C / C params to override those from
the object, returns an URL to the thumbnail, to use in an IMG tag.

=cut

sub thumb_url {
    my ($self, $url, $params) = @_;

    # Get our params, use defaults from the object
    $params ||= {};
    $params->{$_} ||= $self->{$_}
        for qw(size cache cache_dir cache_url_stub);

    # First, if we're caching locally, we need to see if we already have a
    # cached version; if so, it's easy
    if (my $url = $self->_get_cached_url($url, $params)) {
        return $url;
    }

    # Generate the appropriate URL:
    my $uri = URI->new('http://webthumb.bluga.net/easythumb.php');
    $uri->query_form(
        url   => $url,
        size  => $params->{size},
        cache => $params->{cache},
        user  => $self->{user},
        hash  => Digest::MD5::md5_hex(join '',
            strftime("%Y%m%d", gmtime(time())),
            $url,
            $self->{api_key}
        ),
    );

    # If we're caching, we want to fetch the resulting thumbnail and store it
    # locally, then return the URL to that instead
    if ($params->{cache_dir}) {
        my $img_content = LWP::Simple::get($uri);
        if ($img_content) {
            my $url = $self->_cache_image($url, $params, $img_content);
            return $url if defined $url;
        }
    }

    return $uri->as_string;
}

=item easy_thumb

An alias for C.  This name was used in 0.01 to reflect the fact that
it used the L rather than
the full API; however, I think C is rather clearer as to the actual
purpose of the method, and the implementation of it is somewhat unimportant, so
consider this method somewhat deprecated (but likely to be supported
indefinitely.)

=cut

sub easy_thumb { shift->thumb_url(@_); }


sub _get_cached_url {
    my ($self, $url, $params) = @_;

    my $dir = Path::Class::dir($params->{cache_dir})
        or return;
    my $file = $dir->file(
        Digest::MD5::md5_hex($url . $params->{size})
    ) or return;
    my $stat = $file->stat or return;
    if ($stat->mtime < time - ($params->{cache} * 24 * 60 * 60)) {
        $file->remove;
        return;
    } else {
        return $params->{cache_url_stub} . $file->basename;
    }
}

sub _cache_image {
    my ($self, $url, $params, $img_content) = @_;

    my $dir = Path::Class::dir($params->{cache_dir})
        or return;
    my $file = $dir->file(
        Digest::MD5::md5_hex($url . $params->{size})
    ) or return;
    $file->spew($img_content);
    return $params->{cache_url_stub} . $file->basename;
}


=back

=head1 AUTHOR

David Precious, C<<  >>

=head1 ACKNOWLEDGEMENTS

James Ronan


=head1 CONTRIBUTING

This module is developed on GitHub at:

L

Bug reports / suggestions / pull requests are all very welcome.

If you find this module useful, please feel free to
L


=head1 BUGS

Bug reports via L
GitHub|https://github.com/bigpresh/WebService-Bluga-Webthumb/issues> are
preferred, as the module is developed on GitHub, and issues can be correlated to
commits.  Bug reports via L
queue|http://rt.cpan.org/NoAuth/ReportBug.html?Queue=WebService-Bluga-Webthumb>
are still valued though, if you'd prefer that way.

=head1 SEE ALSO

See the API documentation at L

For a basic description of the service, see L


=head1 SUPPORT

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

    perldoc WebService::Bluga::Webthumb



=head1 LICENSE AND COPYRIGHT

Copyright 2011 David Precious.

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 http://dev.perl.org/licenses/ for more information.


=cut

1; # End of WebService::Bluga::Webthumb