File Coverage

blib/lib/WWW/HatenaDiary.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

package WWW::HatenaDiary;
use strict;
use warnings;
use Carp;
use URI;
use Web::Scraper;
use WWW::Mechanize;
use WWW::HatenaLogin;
use JSON::Syck 'Load';

our $VERSION = '0.02';

sub new {
    my ($class, $args) = @_;
    my $base     = $args->{group} ? "http://$args->{group}.g.hatena.ne.jp/" :
                                    'http://d.hatena.ne.jp/';
    my $self     = bless {
        base     => $base,
        group    => $args->{group},
        login    => $args->{login} || WWW::HatenaLogin->new({ nologin => 1, %{ $args } }),
        verbose  => $args->{verbose},
    }, $class;

    if ($self->is_loggedin) {
        my $username = scraper {
            process '//td[@class="username"]/a', 'username' => 'TEXT';
            result 'username';
        }->scrape($self->{login}->mech->content, $self->{login}->login_uri);
        $self->{login}->username($username) if !$self->{login}->username;
        $self->{diary}    = $self->{base}.$self->{login}->username.'/';
    }

    $self;
}

sub is_loggedin {
    my $self = shift;
    $self->{login}->is_loggedin;
}

sub login {
    my ($self, $args) = @_;

    $self->{login}->login($args);
    $self->{diary} = $self->{base}.$self->{login}->username.'/';

    !!($self->{rkm} = $self->get_rkm) ||
        croak 'Login failed. Please confirm your username/password';
}

sub get_rkm {
    my $self = shift;
    my $rkm;

    $self->{login}->mech->get("$self->{diary}?mode=json");
    eval {
        $rkm = Load($self->{login}->mech->content)->{rkm};
    };

    $rkm;
}

sub create {
    my ($self, $args) = @_;
    $self->_post_entry($args);
}

sub create_day {
    shift->update_day(@_);
}

sub retrieve {
    my ($self, $args) = @_;

    croak('URI for the entry is required')
        if !$args->{uri};

    $self->{login}->mech->get("$args->{uri}?mode=json");
    Load($self->{login}->mech->content);
}

sub retrieve_day {
    my ($self, $args) = @_;

    croak('Date is required')
        if !$args->{date};

    if ($args->{date} =~ /^(\d{4})-(\d{2})-(\d{2})$/) {
        my ($y, $m, $d) = ($1, $2, $3);

        my $uri = "$self->{diary}edit?date=$y$m$d";
        $self->{login}->mech->get($uri);
        my $form = $self->{login}->mech->form_name('edit');

        {
            title => $form->value('title'),
            body  => $form->value('body'),
        };
    } else {
        carp "Invalid ymd format: $args->{date}. YYYY-MM-DD formatted date is required.";
    }
}

sub update {
    my ($self, $args) = @_;

    croak('URI for the entry is required')
        if !$args->{uri};

    $self->_post_entry($args);
    $args->{uri};
}

sub update_day {
    my ($self, $args) = @_;

    croak('Date is required')
        if !$args->{date};

    if ($args->{date} =~ /^(\d{4})-(\d{2})-(\d{2})$/) {
        my ($y, $m, $d) = ($1, $2, $3);

        my $uri = "$self->{diary}edit?date=$y$m$d";
        $self->{login}->mech->get($uri);
        $self->{login}->mech->submit_form(
            form_name => 'edit',
            fields => {
                title => $args->{title},
                body  => $args->{body},
                year  => $y,
                month => $m,
                day   => $d,
            },
        );
    }
    else {
        carp "Invalid ymd format: $args->{date}. YYYY-MM-DD formatted date is required.";
    }

    $self->{login}->mech->success;
}

# XXX: It's dubious if this implementation is correct...
sub delete {
    my ($self, $args) = @_;

    croak('URI for the entry is required')
        if !$args->{uri};

    my ($y, $m, $d, $slag) = $args->{uri} =~ m|^$self->{diary}(\d{4})(\d{2})(\d{2})/(.+)$|;
    my $body = $self->retrieve_day({date => join('-', $y, $m, $d)})->{body};

    croak "Entry for $args->{uri} not found"
        if !$body;

    my @update_body = ();
    my $delete_flag = 0;
    my $match       = qr/\*$slag\*/;
    my $unmatch     = qr/\*(.+)\*/;

    for ($body =~ /^(.*)$/mg) {
        $delete_flag = 0 if /$unmatch/ && $delete_flag;
        $delete_flag = 1 if /$match/;
        push @update_body, $_ if !$delete_flag;
    }

    $self->update_day({
        date => join('-', $y, $m, $d),
        body => join("\n", @update_body),
    });
}

sub delete_day {
    my ($self, $args) = @_;

    croak('Date is required')
        if !$args->{date};

    if ($args->{date} =~ /^(\d{4})-(\d{2})-(\d{2})$/) {
        my ($y, $m, $d) = ($1, $2, $3);
        my $uri = "$self->{diary}edit?date=$y$m$d";

        $self->{login}->mech->get($uri);

        if ($self->{group}) {
            for my $form ($self->{login}->mech->forms) {
                if ($form->action =~ /deletediary$/) {
                    $self->{login}->mech->request($form->click);
                }
            }
        }
        else {
            $self->{login}->mech->submit_form(form_number => 2);
        }
    }
    else {
        carp "Invalid ymd format: $args->{date}. YYYY-MM-DD formatted date is required.";
    }

    $self->{login}->mech->success;
}

sub _post_entry {
    my ($self, $args) = @_;
    my $uri = $args->{uri} || $self->{diary};

    $self->{login}->mech->post($uri, {
        rkm => $self->{rkm},
        %$args,
    });

    $self->{login}->mech->get($uri);

    scraper {
        process '//div[@class="section"][1]/h3[1]/a[1]', 'uri' => '@href';
        result 'uri';
    }->scrape($self->{login}->mech->content, URI->new($self->{diary}));
}

1;

__END__