File Coverage

blib/lib/WebService/Tumblr.pm

Criterion	Covered	Total	%
statement	117	164	71.3
branch	35	64	54.6
condition	7	21	33.3
subroutine	24	36	66.6
pod	3	20	15.0
total	186	305	60.9

package WebService::Tumblr;
BEGIN {
  $WebService::Tumblr::VERSION = '0.0010';
}
# ABSTRACT: A Perl interface to the Tumblr web API


use strict;
use warnings;

use Any::Moose;
use LWP::UserAgent;
use HTTP::Request::Common();
use URI::PathAbstract;
use JSON;
our $json = JSON->new->pretty;
sub json { $json }

use WebService::Tumblr::Dispatch;
use WebService::Tumblr::Result;

use constant TUMBLR_URL => 'http://www.tumblr.com';

sub empty ($) {
    return not defined $_[0] && length $_[0];
}

sub hash_refactor {
    my %arguments = @_;
    my ( $hash, $key0, $else, $delete, $exclusive, $exists ) = @arguments{qw/ hash key else delete exclusive exists /};

    # FIXME Return value of key0
    return unless defined $else;
    $else = [ $else ] unless ref $else eq 'ARRAY';

    my @found;
    for my $key ( $key0, @$else ) {
        if ( $exists ) {
            if ( $exists eq 'empty' )   { push @found, $key if ! empty $hash->{ $key } }
            else                        { push @found, $key if exists $hash->{ $key } }
        }
        else                            { push @found, $key if $hash->{ $key } }
    }

    return unless @found;

    my $has;
    if ( @found and $found[ 0 ] eq $key0 ) {
        $has = 1;
        shift @found;
    }

    my $value;
    if ( $exclusive ) {
        if ( $has && @found ) {
            die "Exclusivity violated: $key0 @found";
        }

        if ( @found > 1 ) {
            die "Exclusivity violated: @found";
        }
    }

    if ( $has ) {
        if ( $delete ) {
            delete $hash->{ $_ } for @found;
        }
        return $hash->{ $key0 };
    }
    else {
        my $value = $hash->{ $found[0] };
        if ( $delete ) {
            delete $hash->{ $_ } for @found;
        }
        return $hash->{ $key0 } = $value;
    }
}

sub _urlify ($) {
    my $given = shift;

    return if empty $given;

    if ( $given !~ m/\./ ) {
        $given = "$given.tumblr.com";
    }
    if ( $given !~ m/^[A-Za-z0-9]+:\/\// ) {
        $given = "http://$given";
    }

    return $given;
}

sub _url_from ($) {
    my $self = shift;
    my $given = shift;

    my ( $url, $blog ) = delete @$given{qw/ url blog /};

    return _urlify $url unless empty $url;
    return _urlify $blog unless empty $blog;
    return;
}

sub _extract ($@) {
    my $self = shift;
    my $given = shift;

    my %return;
    for ( @_ ) {
        $return{ $_ } = delete $given->{ $_ } if exists $given->{ $_ };
    }

    return \%return;
}

sub BUILD {
    my $self = shift;
    my $given = shift;

    die "*** Two or more of: name, blog, url" if 1 < grep { ! empty $given->{ $_ } } qw/ name blog url /;
    ! empty $given->{ $_ } and $self->url( $given->{ $_ } ) for qw/ name blog /;
}

has secure => qw/ is rw default 1 /;

has agent => qw/ is ro lazy_build 1 /;
sub _build_agent {
    my $agent = LWP::UserAgent->new;
    return $agent;
}

has [qw/ email password /] => qw/ is rw /;

has _name => qw/ is rw /;
has url => qw/ is rw /, trigger => sub {
    my ( $self, $value ) = @_;
    my $url = _urlify $value;
    if ( empty $url ) {
        $self->_name( undef );
        return undef;
    }
    my $uri = URI->new( $url );
    my $host = $uri->host;
    if ( $host =~ m/^([^\.]+)\.tumblr.com$/ )   { $self->_name( $1 ) }
    else                                        { $self->_name( $host ) }
    $self->{ url } = $url; # FIXME This is a hack, do this better
};

sub name {
    my $self = shift;
    return $self->_name unless @_;
    $self->url( @_ );
}

sub blog { return shift->name( @_ ) }

sub _url {
    my $self = shift;
    my $url = $self->url;
    die "*** Missing url" unless $self->url;
    return _urlify $url;
}

sub identity {
    my $self = shift;
    if ( @_ ) {
        my ( $email, $password ) = @_;
        $self->email( $email );
        $self->password( $password );
    }
    else {
        return ( $self->email, $self->password );
    }
}

sub new_dispatch {
    my $self = shift;
    return WebService::Tumblr::Dispatch->new( tumblr => $self, @_ );
}

sub dispatch {
    my $self = shift;
    my $arguments = shift;
    my %options = @_;

    my $base = TUMBLR_URL;
    $base = URI->new( $base );
    $base->scheme( 'https' ) if $self->secure;

    if ( $options{ url } ) {
        $base = $self->_url_from( $arguments );
        $base ||= $self->_url;
    }
    my $url = URI::PathAbstract->new( $base, path => $options{ path } );
    my $query = $self->_extract( $arguments, @{ $options{ passthrough } || [] } );
    my $dispatch = $self->new_dispatch( method => 'GET', url => $url, query => $query );
    $dispatch->authenticate if $options{ authenticate };

    return $dispatch;
}

sub write {
    my $self = shift;
    my %arguments = @_;

    my $dispatch = $self->dispatch( \%arguments,
        path => 'api/write',
        passthrough => [qw/
            email password type generator date private tags format group slug state send-to-twitter
            post-id
            title body
            source data caption click-through-url
            quote source
            name url description
            title conversation
            embed data title caption
            data externally-hosted-url caption
        /],
        authenticate => 1,
    );

    return $dispatch;
}

sub edit {
    my $self = shift;
    my %arguments = @_;

    die "*** Missing post-id" unless $arguments{ 'post-id' };

    return $self->write( @_ );
}

sub delete {
    my $self = shift;
    my %arguments = @_;

    my $dispatch = $self->dispatch( \%arguments,
        path => 'api/delete',
        passthrough => [qw/ email password post-id /],
        authenticate => 1,
    );

    return $dispatch;
}

sub reblog {
    my $self = shift;
    my %arguments = @_;

    my $dispatch = $self->dispatch( \%arguments,
        path => 'api/delete',
        passthrough => [qw/ email password post-id reblog-key comment as /],
        authenticate => 1,
    );

    return $dispatch;
}

sub pages {
    my $self = shift;
    my %arguments = @_;

    my $dispatch = $self->dispatch( \%arguments,
        url => 1,
        path => 'api/pages',
        passthrough => [qw/ email password /],
    );
    $dispatch->authenticate if $arguments{ all } || $dispatch->query->{ state };

    return $dispatch;
}

sub posts {
    my $self = shift;
    my %arguments = @_;

    my $dispatch = $self->dispatch( \%arguments,
        url => 1,
        path => 'api/read',
        passthrough => [qw/ email password start num type id filter tagged chrono search state /],
    );
    $dispatch->authenticate if $arguments{ all } || $dispatch->query->{ state };

    return $dispatch;
}

sub read {
    my $self = shift;

    return $self->posts( @_ );
}

sub dashboard {
    my $self = shift;
    my %arguments = @_;

    my $dispatch = $self->dispatch( \%arguments,
        path => 'api/dashboard',
        passthrough => [qw/ email password start num filter likes /],
        authenticate => 1,
    );

    return $dispatch;
}

sub likes {
    my $self = shift;
    my %arguments = @_;

    my $dispatch = $self->dispatch( \%arguments,
        path => 'api/dashboard',
        passthrough => [qw/ email password start num filter /],
        authenticate => 1,
    );

    return $dispatch;
}

sub like {
    my $self = shift;
    my %arguments = @_;

    my $dispatch = $self->dispatch( \%arguments,
        path => 'api/like',
        passthrough => [qw/ email password post-id reblog-key /],
        authenticate => 1,
    );

    return $dispatch;
}

sub authenticate {
    my $self = shift;
    my %arguments = @_;

    my $dispatch = $self->dispatch( \%arguments,
        path => 'api/authenticate',
        passthrough => [qw/ email password include-theme /],
        authenticate => 1,
    );

    return $dispatch;
}

1;

__END__