File Coverage

blib/lib/Net/Flickr/API.pm

Criterion	Covered	Total	%
statement	27	200	13.5
branch	0	56	0.0
condition	0	6	0.0
subroutine	9	21	42.8
pod	6	10	60.0
total	42	293	14.3

use strict;

# $Id: API.pm,v 1.35 2009/08/02 17:16:12 asc Exp $
# -*-perl-*-

package Net::Flickr::API;

$Net::Flickr::API::VERSION = '1.7';

=head1 NAME

Net::Flickr::API - base API class for Net::Flickr::* libraries

=head1 SYNOPSIS

 package Net::Flickr::RDF;
 use base qw (Net::Flickr::API);

=head1 DESCRIPTION

Base API class for Net::Flickr::* libraries

Net::Flickr::API is a wrapper for Flickr::API that provides support for throttling
API calls (per second), retries if the API is disabled and marshalling of API responses
into XML::LibXML or XML::XPath objects.

=head1 OPTIONS

Options are passed to Net::Flickr::Backup using a Config::Simple object or
a valid Config::Simple config file. Options are grouped by "block".

=head2 flick

=over 4

=item * B

String. I

A valid Flickr API key.

=item * B

String. I

A valid Flickr Auth API secret key.

=item * B

String. I

A valid Flickr Auth API token.

=item * B

String. I

The B defines which XML/XPath handler to use to process API responses.

=over 4

=item * B

Use XML::LibXML.

=item * B

Use XML::XPath.

=back

=back

=head2 reporting

=over

=item * B

Boolean.

Default is false.

=item * B

String.

The default handler is B, as in C

=item * B

For example, the following :

 reporting_handler_args=name:foobar;min_level=info

Would be converted as :

 (name      => "foobar",
  min_level => "info");

The default B argument is "__report". The default B argument
is "info".

=back

=cut

use Config::Simple;

use Flickr::API;
use Flickr::Upload;

use Readonly;
use Data::Dumper;

use Log::Dispatch;
use Log::Dispatch::Screen;

Readonly::Scalar my $PAUSE_SECONDS_OK          => 2;
Readonly::Scalar my $PAUSE_SECONDS_UNAVAILABLE => 4;
Readonly::Scalar my $PAUSE_MAXTRIES            => 10;
Readonly::Scalar my $PAUSE_ONSTATUS            => 503;

Readonly::Scalar my $RETRY_MAXTRIES            => 10;

=head1 PACKAGE METHODS

=cut

=head2 __PACKAGE__->new($cfg)

Where B<$cfg> is either a valid I object or the path
to a file that can be parsed by I.

Returns a I object.

=cut

sub new {
        my $pkg = shift;
        my $cfg = shift;

        my $self = {'__wait'    => time() + $PAUSE_SECONDS_OK,
                    '__paused'  => 0,
                    '__retries' => 0,};

        bless $self,$pkg;

        if (! $self->init($cfg)) {
                undef $self;
        }

        return $self;
}

sub init {
        my $self = shift;
        my $cfg  = shift;

        $self->{cfg} = (UNIVERSAL::isa($cfg, "Config::Simple")) ? $cfg : Config::Simple->new($cfg);

        if ($self->{cfg}->param("flickr.api_handler") !~ /^(?:XPath|LibXML)$/) {
                warn "Invalid API handler";
                return 0;
        }

        #

        my $log_fmt = sub {
                my %args = @_;

                my $msg = $args{'message'};
                chomp $msg;

                if ($args{'level'} eq "error") {

                        my ($ln, $sub) = (caller(4))[2,3];
                        $sub =~ s/.*:://;

                        return sprintf("[%s][%s, ln%d] %s\n",
                                       $args{'level'}, $sub, $ln, $msg);
                }

                return sprintf("[%s] %s\n", $args{'level'}, $msg);
        };

        my $logger = Log::Dispatch->new(callbacks=>$log_fmt);
        my $error  = Log::Dispatch::Screen->new(name      => '__error',
                                                min_level => 'error',
                                                stderr    => 1);

        $logger->add($error);

        #
        # Custom report logging
        #

        if ($self->{cfg}->param("reporting.enable")) {

                my $report_handler = $self->{cfg}->param("reporting.handler") || "Screen";
                $report_handler    =~ s/:://g;

                my $report_pkg = "Log::Dispatch::$report_handler";
                eval "require $report_pkg";

                if ($@) {
                        warn "Failed to load $report_pkg, $@";
                        return 0;
                }

                my %report_args = ();

                if (my $args = $self->{cfg}->param("reporting.handler_args")) {

                        foreach my $part (split(",", $args)) {
                                my ($key, $value) = split(":", $part);
                                $report_args{$key} = $value;
                        }
                }

                $report_args{'name'}      ||= "__report";
                $report_args{'min_level'} ||= "info";

                my $reporter = $report_pkg->new(%report_args);

                if (! $reporter) {
                        warn "Failed to instantiate $report_pkg, $!";
                        return 0;
                }

                $logger->add($reporter);
        }

        $self->{'__logger'} = $logger;

        #

        $self->{api} = Flickr::API->new({key     => $self->{cfg}->param("flickr.api_key"),
                                         secret  => $self->{cfg}->param("flickr.api_secret"),
                                         handler => $self->{cfg}->param("flickr.api_handler")});

        my $pkg     = ref($self);
        my $version = undef;

        do {
                my $ref = join("::", $pkg, "VERSION");

                no strict "refs";
                $version = ${$ref};
        };

        my $agent_string = sprintf("%s/%s", $pkg, $version);

        $self->{api}->agent($agent_string);
        return 1;
}

=head1 OBJECT METHODS

=cut

=head2 $obj->api_call(\%args)

Valid args are :

=over 4

=item * B

A string containing the name of the Flickr API method you are
calling.

=item * B

A hash ref containing the key value pairs you are passing to
I

=back

If the method encounters any errors calling the API, receives an API error
or can not parse the response it will log an error event, via the B method,
and return undef.

Otherwise it will return a I object (if XML::LibXML is
installed) or a I object.

=cut

sub api_call {
        my $self = shift;
        my $args = shift;

        #

        # check to see if we need to take
        # breather (are we pounding or are
        # we not?)

        while (time < $self->{'__wait'}) {

                my $debug_msg = sprintf("trying not to beat up the Flickr servers, pause for %.2f seconds\n",
                                        $PAUSE_SECONDS_OK);

                $self->log()->debug($debug_msg);
                sleep($PAUSE_SECONDS_OK);
        }

        # send request

        if (exists($args->{'args'}->{'api_sig'})) {
                delete $args->{'args'}->{'api_sig'};
        }

        $args->{'args'}->{'auth_token'} = $self->{cfg}->param("flickr.auth_token");

        #

        my $req = Flickr::API::Request->new($args);
        my $res = undef;

        $self->log()->debug("calling $args->{method} : " . Dumper($args->{args}));

        eval {
                $res = $self->{'api'}->execute_request($req);
        };

        if ($@) {
                $self->log()->error("Fatal error calling the Flickr API, $@");

                $self->{'__wait'}   = time + $PAUSE_SECONDS_OK;
                $self->{'__paused'} = 0;
                return undef;
        }

        #
        # check for 503 status
        #

        if ($res->code() eq $PAUSE_ONSTATUS) {
                $res = $self->retry_api_call($args, $res);
        }

        $self->{'__wait'}   = time + $PAUSE_SECONDS_OK;
        $self->{'__paused'} = 0;

        return $self->parse_api_call($args, $res);
}

=head2 $obj->get_auth()

Return an XML I element containing the Flickr auth token information for
the current object.

Returns undef if no token information is present.

=cut

sub get_auth {
        my $self = shift;

        if (! $self->{'__auth'}) {
                my $auth = $self->api_call({"method" => "flickr.auth.checkToken"});

                if (! $auth) {
                        return undef;
                }

                my $nsid = $auth->find("/rsp/auth/user/\@nsid")->string_value();

                if (! $nsid) {
                        $self->log()->error("unabled to determine ID for token");
                        return undef;
                }

                $self->{'__auth'} = $auth;
        }

        return $self->{'__auth'};
}

=head2 $obj->get_auth_nsid()

Return the Flickr NSID of the user associated with the Flickr auth token information
for the current object.

Returns undef if no token information is present.

=cut

sub get_auth_nsid {
        my $self = shift;

        if (my $auth = $self->get_auth()){
                return $auth->find("/rsp/auth/user/\@nsid")->string_value();
        }

        return undef;
}

sub parse_api_call {
        my $self = shift;
        my $args = shift;
        my $res  = shift;

        $self->log()->debug($res->decoded_content());

        my $xml = $self->_parse_results_xml($res);

        if (! $xml) {
                $self->log()->error("failed to parse API response, calling $args->{method}");
                $self->log()->error($res->decoded_content());
                return undef;
        }

        my $stat = $xml->find("/rsp/\@stat")->string_value();

        if ($stat eq "fail") {
                my $code = $xml->findvalue("/rsp/err/\@code");
                my $msg  = $xml->findvalue("/rsp/err/\@msg");

                $self->log()->error(sprintf("[%s] %s (calling $args->{method})\n",
                                            $code,
                                            $msg));

                if ($code==0) {
                        $self->log()->info(sprintf("api disabled attempting %s/%s tries to see if it's come back up", $self->{'__retries'}, $RETRY_MAXTRIES));
                        return $self->api_disabled($args, $res);
                }
        }

        $self->{'__retries'} = 0;

        return ($@) ? undef : $xml;
}

sub _parse_results_xml {
        my $self = shift;
        my $res  = shift;

        my $xml = undef;

        #
        # Please for Cal to someday accept the patch to add
        # response handlers to Flickr::API...
        #

        if ($self->{cfg}->param("flickr.api_handler") eq "XPath") {
                eval "require XML::XPath";

                if (! $@) {
                        eval {
                                $xml = XML::XPath->new(xml=>$res->decoded_content());
                        };
                }
        }

        else {
                eval "require XML::LibXML";

                if (! $@) {
                        eval {
                                my $parser = XML::LibXML->new();
                                $xml = $parser->parse_string($res->decoded_content());
                        };
                }
        }

        #

        if (! $xml) {
                $self->log()->error("XML parse error : $@");
                return undef;
        }

        #

        return $xml;
}

sub api_disabled {
        my $self = shift;
        my $args = shift;
        my $res  = shift;

        $self->{'__retries'} ++;

        if ($self->{'__retries'} > $RETRY_MAXTRIES) {
                $self->log()->critical(sprintf("API still down after %s tries - exiting", $RETRY_MAXTRIES));
                exit;
        }

        $res = $self->retry_api_call($args, $res);

        if (! $res) {
                $self->log()->critical("Returned false during 'api disabled' retry. That can only be bad - exiting");
                exit;
        }

        return $res;
}

sub retry_api_call {
        my $self = shift;
        my $args = shift;
        my $res  = shift;

        # you are in a dark and twisty corridor
        # where all the errors look the same -
        # just give up if we hit this ceiling

        $self->{'__paused'} ++;

        if ($self->{'__paused'} > $PAUSE_MAXTRIES) {

                my $errmsg = sprintf("service returned '%d' status %d times; exiting",
                                     $PAUSE_ONSTATUS, $PAUSE_MAXTRIES);

                $self->log()->error($errmsg);
                return undef;
        }

        my $retry_after = $res->header("Retry-After");
        my $debug_msg   = undef;

        if ($retry_after ) {
                $debug_msg = sprintf("service unavailable, requested to retry in %d seconds",
                                     $retry_after);
        }

        else {
                $retry_after = $PAUSE_SECONDS_UNAVAILABLE * $self->{'__paused'};
                $debug_msg = sprintf("service unavailable, pause for %.2f seconds",
                                     $retry_after);
        }

        $self->log()->debug($debug_msg);
        sleep($retry_after);

        # try, try again

        return $self->api_call($args);
}

=head2 $obj->upload(\%args)

This is a helper method that simply wraps calls to the I upload
method. All the arguments are the same. For complete documentation please consult:

L

(Note: There's no need to pass an auth_token argument as the wrapper will take care
of for you.)

Returns a photo ID (or a ticket ID if the call is asynchronous) on success or false
if there was a problem.

=cut

sub upload {
        my $self = shift;
        my $args = shift;

        $args->{'auth_token'} = $self->{cfg}->param("flickr.auth_token");

        my $ua = Flickr::Upload->new({'key' => $self->{cfg}->param("flickr.api_key"),
                                      'secret' => $self->{cfg}->param("flickr.api_secret")});

        my $id = undef;

        eval {
                $id = $ua->upload(%$args);
        };

        if ($@){
                $self->log()->error("upload failed: $@");
                return 0;
        }

        return $id;
}

=head2 $obj->log()

Returns a I object.

=cut

sub log {
        my $self = shift;
        return $self->{'__logger'};
}

=head1 VERSION

1.7

=head1 DATE

$Date: 2009/08/02 17:16:12 $

=head1 AUTHOR

Aaron Straup Cope [e-mail]

=head1 SEE ALSO

L

L

L

L

=head1 BUGS

Please report all bugs via http://rt.cpan.org/

=head1 LICENSE

Copyright (c) 2005-2008 Aaron Straup Cope. All Rights Reserved.

This is free software. You may redistribute it and/or
modify it under the same terms as Perl itself.

=cut

return 1;

__END__