File Coverage

blib/lib/WWW/Pastebin/Sprunge/Create.pm

Criterion	Covered	Total	%
statement	36	62	58.0
branch	1	20	5.0
condition	2	13	15.3
subroutine	10	13	76.9
pod	2	2	100.0
total	51	110	46.3

package WWW::Pastebin::Sprunge::Create;
use strict;
use warnings;
# ABSTRACT: create new pastes on sprunge.us
our $VERSION = '0.009'; # VERSION
use Carp;
use URI;
use LWP::UserAgent;
use HTTP::Request::Common;
use Encode;
use base 'Class::Data::Accessor';
__PACKAGE__->mk_classaccessors(qw(
    ua
    paste_uri
    error
));

use overload q|""| => sub { shift->paste_uri; };


sub new {
    my $class = shift;
    croak 'Must have even number of arguments to new()'
        if @_ & 1;

    my %args = @_;
    $args{ +lc } = delete $args{ $_ } for keys %args;

    $args{timeout} ||= 30;
    $args{ua} ||= LWP::UserAgent->new(
        timeout => $args{timeout},
        agent   => 'WWW::Pastebin::Sprunge (+http://p3rl.org/WWW::Pastebin::Sprunge)',
    );

    my $self = bless {}, $class;
    $self->ua( $args{ua} );

    return $self;
}


sub paste {
    my ( $self, $text ) = splice @_, 0, 2;

    $self->$_(undef) for qw(paste_uri error);

    defined $text or carp 'Undefined paste content' and return;

    croak 'Must have even number of optional arguments to paste()'
        if @_ & 1;

    my %args = @_;
    %args = (
        sprunge => $text,
        %args,
    );

    $args{lang} = lc $args{lang} if $args{lang};

    $args{file}
        and not -e $args{sprunge}
        and return $self->_set_error("File $args{sprunge} does not seem to exist");

    my $ua = $self->ua;
    $ua->requests_redirectable( [ ] );

    my @post_request = (
        'http://sprunge.us',
        Content_Type => 'form-data',
        Content => [
            $args{file}
                ? (sprunge => [ $args{sprunge}, '' ])
                : (sprunge => encode_utf8($args{sprunge}))
        ],
    );
    my $response = do {
        local $HTTP::Request::Common::DYNAMIC_FILE_UPLOAD = 1;
        $self->ua->post( @post_request );
    };
    if ( $response->is_success() ) {
        my $uri = URI->new($response->{_content});
        return $self->_set_error(q{Request was successful but I don't see a link to the paste }
                . $response->code
                . $response->content
        ) unless $uri;
        $uri->query($args{lang}) if $args{lang};
        return $self->paste_uri($uri);
    }
    else {
        return $self->_set_error($response, 'net');
    }
}


sub _set_error {
    my ( $self, $error, $type ) = @_;

    if ( defined $type and $type eq 'net' ) {
        $self->error( 'Network error: ' . $error->status_line );
    }
    else {
        $self->error( $error );
    }
    return;
}


1;

__END__