File Coverage

blib/lib/Net/Laconica.pm

Criterion	Covered	Total	%
statement	45	91	49.4
branch	10	50	20.0
condition	9	21	42.8
subroutine	9	16	56.2
pod	3	3	100.0
total	76	181	41.9

package Net::Laconica;

use warnings;
use strict;
use HTML::Parser;
use LWP::UserAgent;
use Data::Validate qw(is_alphanumeric);
use Data::Validate::URI qw(is_http_uri);
use Carp;

our $VERSION = '0.08';

my $ua = LWP::UserAgent->new;
$ua->agent('Mozilla');
$ua->cookie_jar({ file => 'cookies.txt' });


sub new {
    my $class = shift;
    my $self  = { login => 1, @_ };

    unless( exists $self->{uri} && exists $self->{username} && exists $self->{password}
        or exists $self->{uri} && exists $self->{username} ) {
        croak 'Invalid arguments';
    }

    # Sanitise arguments and check for validity
    is_http_uri($self->{uri}) || croak 'Invalid URI';
    is_alphanumeric($self->{username}) || croak 'Invalid username';

    # Append a slash at the end of uri if it does not end with one
    if( substr($self->{uri}, (length $self->{uri}) - 1, 1) ne '/' ) {
        $self->{uri} .= '/';
    }

    # Convert the username to lowercase and return the blessed reference
    $self->{username} = lc $self->{username};
    bless $self, $class;
}


sub fetch {
    my $self = shift;
    undef $self->{contents};
    my $number;

    # Get/set the number of messages to be fetched
    if( @_ == 1 ) {
        $number = shift;
        if($number > 20) {
            $number = 20;
        }
    } elsif( @_ == 0 ) {
        $number = 10;
    } else {
        croak 'Invalid arguments';
    }

    # Start fetching messages
    my $p = HTML::Parser->new(api_version => 3);
    $p->handler(start => sub { $self->_start_handler(@_) }, 'self,tagname,attr');
    $p->handler(end   => sub {
        return unless defined $self->{value};
        return if $self->{value} eq 'content' && shift eq 'a';
        $self->{value} = undef;
    }, 'tagname');
    $p->utf8_mode(1);

    my $response = $ua->get($self->{uri} . $self->{username} . '/all');
    $p->parse($response->content);

    unless( $self->{login} ) {
        croak 'Incorrect username';
    }

    # Ignore the first array element which is undef, and return the rest of the elements
    splice @{$self->{contents}}, 1, $number;
}


sub send {
    my $self = shift;
    my $message;

    unless( exists $self->{password} ) {
        return $self->{login} = 0;
    }

    if( @_ == 1 ) {
        # Strip the message to 140 characters if the message is longer
        $message = shift;
        if(length $message > 140) {
            $message = substr $message, 0, 140;
        }
    } else {
        croak 'Invalid arguments';
    }

    # Start sending messages
    my $p = HTML::Parser->new(api_version => 3);
    $p->handler(start => sub { $self->_start_handler(@_) }, 'self,tagname,attr');
    $p->handler(end   => sub {
        return unless defined $self->{value};
        return if $self->{value} eq 'content' && shift eq 'a';
        $self->{value} = undef;
    }, 'tagname');
    $p->utf8_mode(1);

    my $response = $ua->post($self->{uri} . 'main/login', [nickname => $self->{username}, password => $self->{password}]);
    $p->parse($response->content);

    # Return 0 if not logged in
    return 0 unless $self->{login};
    $response = $ua->post($self->{uri} . 'notice/new', [status_textarea => $message, returnto => 'all']);
}


sub _start_handler {
    my $class = shift;
    my $self  = shift;

    return unless exists $_[1]->{class};

    if( $_[1]->{class} eq 'nickname' ) {
        $class->{value} = 'nickname';
        $class->{counter}++;
    } elsif( $_[1]->{class} eq 'content' ) {
        $class->{value} = 'content';
    } elsif( $_[1]->{class} eq 'error' ) {
        $class->{value} = 'error';
    }

    $self->handler(text => sub {
        return unless defined $class->{value};
        if( $class->{value} eq 'content' ) {
            $class->{contents}[$class->{counter}] .= shift;
        } elsif( $class->{value} eq 'nickname' ) {
            $class->{contents}[$class->{counter}] .= shift(@_) . ': ';
        } elsif( $class->{value} eq 'error' ) {
            my $error = shift;
            if( $error eq 'Incorrect username or password.' || $error eq 'No such user.' ) {
                $class->{login} = 0;
            }
        }
    }, 'dtext');
}

1;

__END__