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


line stmt bran cond sub pod time code
1             package WWW::Pastebin::Sprunge::Create;
2 1     1   1849 use strict;
  1         2  
  1         35  
3 1     1   5 use warnings;
  1         2  
  1         44  
4             # ABSTRACT: create new pastes on sprunge.us
5             our $VERSION = '0.009'; # VERSION
6 1     1   6 use Carp;
  1         2  
  1         60  
7 1     1   6 use URI;
  1         2  
  1         19  
8 1     1   5 use LWP::UserAgent;
  1         8  
  1         29  
9 1     1   897 use HTTP::Request::Common;
  1         3215  
  1         187  
10 1     1   8 use Encode;
  1         2  
  1         99  
11 1     1   6 use base 'Class::Data::Accessor';
  1         2  
  1         167  
12             __PACKAGE__->mk_classaccessors(qw(
13             ua
14             paste_uri
15             error
16             ));
17              
18 1     1   6 use overload q|""| => sub { shift->paste_uri; };
  1     0   3  
  1         13  
  0         0  
19              
20              
21             sub new {
22 1     1 1 82 my $class = shift;
23 1 50       28 croak 'Must have even number of arguments to new()'
24             if @_ & 1;
25              
26 1         4 my %args = @_;
27 1         5 $args{ +lc } = delete $args{ $_ } for keys %args;
28              
29 1   50     10 $args{timeout} ||= 30;
30 1   33     16 $args{ua} ||= LWP::UserAgent->new(
31             timeout => $args{timeout},
32             agent => 'WWW::Pastebin::Sprunge (+http://p3rl.org/WWW::Pastebin::Sprunge)',
33             );
34              
35 1         12258 my $self = bless {}, $class;
36 1         9 $self->ua( $args{ua} );
37              
38 1         102 return $self;
39             }
40              
41              
42             sub paste {
43 0     0 1   my ( $self, $text ) = splice @_, 0, 2;
44              
45 0           $self->$_(undef) for qw(paste_uri error);
46              
47 0 0 0       defined $text or carp 'Undefined paste content' and return;
48              
49 0 0         croak 'Must have even number of optional arguments to paste()'
50             if @_ & 1;
51              
52 0           my %args = @_;
53 0           %args = (
54             sprunge => $text,
55             %args,
56             );
57              
58 0 0         $args{lang} = lc $args{lang} if $args{lang};
59              
60 0 0 0       $args{file}
61             and not -e $args{sprunge}
62             and return $self->_set_error("File $args{sprunge} does not seem to exist");
63              
64 0           my $ua = $self->ua;
65 0           $ua->requests_redirectable( [ ] );
66              
67 0 0         my @post_request = (
68             'http://sprunge.us',
69             Content_Type => 'form-data',
70             Content => [
71             $args{file}
72             ? (sprunge => [ $args{sprunge}, '' ])
73             : (sprunge => encode_utf8($args{sprunge}))
74             ],
75             );
76 0           my $response = do {
77 0           local $HTTP::Request::Common::DYNAMIC_FILE_UPLOAD = 1;
78 0           $self->ua->post( @post_request );
79             };
80 0 0         if ( $response->is_success() ) {
81 0           my $uri = URI->new($response->{_content});
82 0 0         return $self->_set_error(q{Request was successful but I don't see a link to the paste }
83             . $response->code
84             . $response->content
85             ) unless $uri;
86 0 0         $uri->query($args{lang}) if $args{lang};
87 0           return $self->paste_uri($uri);
88             }
89             else {
90 0           return $self->_set_error($response, 'net');
91             }
92             }
93              
94              
95             sub _set_error {
96 0     0     my ( $self, $error, $type ) = @_;
97              
98 0 0 0       if ( defined $type and $type eq 'net' ) {
99 0           $self->error( 'Network error: ' . $error->status_line );
100             }
101             else {
102 0           $self->error( $error );
103             }
104 0           return;
105             }
106              
107              
108             1;
109              
110             __END__