File Coverage

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

Criterion	Covered	Total	%
statement	59	63	93.6
branch	15	26	57.6
condition	3	10	30.0
subroutine	14	15	93.3
pod	7	7	100.0
total	98	121	80.9

package WWW::Pastebin::PastebinCa::Create;

use warnings;
use strict;

our $VERSION = '0.004';
use Carp;
use URI;
use WWW::Mechanize;

my %Valid_Langs   = valid_langs();
my %Valid_Expires = map { $_ => $_ } valid_expires();
use overload q|""| => sub { shift->paste_uri };

sub new {
    my $self = bless {}, 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{mech}    ||= WWW::Mechanize->new(
        autocheck => 0,
        timeout => $args{timeout},
        agent   => 'Mozilla/5.0 (X11; U; Linux x86_64; en-US; rv:1.8.1.12)'
                    .' Gecko/20080207 Ubuntu/7.10 (gutsy) Firefox/2.0.0.12',
    );

    $self->mech( $args{mech} );

    return $self;
}

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

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

    defined $content
        or carp "first argument to paste() is not defined" and return;

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

    my %args = @_;
    $args{ +lc } = delete $args{ $_ } for keys %args;
    %args = (
        content     => $content,
        name        => '',
        desc        => '',
        tags        => '',
        lang        => 1,
        expire      => '',
        %args,
    );

    croak q|Invalid 'lang' was specified to paste(). |
        . q|print Dumper { WWW::Pastebin::PastebinCa::Create::valid_langs }|
        unless exists $Valid_Langs{ $args{lang} };

    croak q|Invalid 'expire' was specified to paste(). |
      . q|print Dumper { WWW::Pastebin::PastebinCa::Create::valid_expires }|
        if length $args{expire}
            and not exists $Valid_Expires{ $args{expire} };

    my $mech = $self->mech;
    $mech->get('http://pastebin.ca');

    return $self->_set_error('Network error: ' . $mech->res->status_line)
        unless $mech->success;

    $mech->form_with_fields( 'content' )
        or return $self->_set_error('Paste form was not found');

    my $set = $mech->set_visible(
        $args{content},
        [ text      => $args{name}   ],
        [ textarea  => $args{desc}   ],
        [ text      => $args{tags}   ],
        [ option    => $args{lang}   ],
        [ option    => $args{expire} ],
    );

    $set == 6
        or return $self->_set_error("Failed to set all fields (only $set)");

    $mech->click('s')->is_success
        or return $self->_set_error(
            'Network error: ' . $mech->res->status_line
        );

    my ( $uri ) = $mech->content
    =~ m|

    defined $uri
        or return $self->_set_error('Failed to locate link to paste');

    return $self->paste_uri( URI->new($uri) );
}

sub _set_error {
    my ( $self, $error ) = @_;
    $self->error( $error );
    return;
}

sub valid_langs {
    return (
         1 => 'Raw',
         2 => 'Asterisk Configuration',
         3 => 'C Source',
         4 => 'C++ Source',
         5 => 'PHP Source',
         6 => 'Perl Source',
         7 => 'Java Source',
         8 => 'Visual Basic Source',
         9 => 'C# Source',
        10 => 'Ruby Source',
        11 => 'Python Source',
        12 => 'Pascal Source',
        13 => 'mIRC Script',
        14 => 'PL/I Source',
        15 => 'XML Document',
        16 => 'SQL Statement',
        17 => 'Scheme Source',
        18 => 'Action Script',
        19 => 'Ada Source',
        20 => 'Apache Configuration',
        21 => 'Assembly (NASM)',
        22 => 'ASP',
        23 => 'BASH Script',
        24 => 'CSS',
        25 => 'Delphi Source',
        26 => 'HTML 4.0 Strict',
        27 => 'JavaScript',
        28 => 'LISP Source',
        29 => 'Lua Source',
        30 => 'Microprocessor ASM',
        31 => 'Objective C',
        32 => 'Visual Basic .NET',
        33 => 'Script Log',
        34 => 'Diff / Patch',
    );
}

sub valid_expires {
    return (
        '2 hours',
        '4 hours',
        '1 year',
        '2 weeks',
        '45 minutes',
        '2 months',
        '30 minutes',
        '1 week',
        '1 hour',
        '15 minutes',
        '10 minutes',
        '3 days',
        '5 months',
        '4 months',
        '5 minutes',
        '8 hours',
        '2 days',
        '3 months',
        '1 day',
        '12 hours',
        '3 weeks',
        '6 months',
        '1 month',
    );
}

sub mech {
    my $self = shift;
    if ( @_ ) { $self->{MECH} = shift };
    return $self->{MECH};
}

sub paste_uri {
    my $self = shift;
    if ( @_ ) { $self->{PASTE_URI} = shift };
    return $self->{PASTE_URI};
}

sub error {
    my $self = shift;
    if ( @_ ) { $self->{ERROR} = shift };
    return $self->{ERROR};
}

1;
__END__