root/lang/perl/WWW-HatenaDiary/trunk/lib/WWW/HatenaDiary.pm @ 4276

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

our $VERSION = '0.01';

sub new {
    my ($class, $args) = @_;

    croak 'Both login_id and login_pw are required'
        if grep { !$args->{$_} } qw(login_id login_pw);

    my $login_id = $args->{login_id};
    my $login_pw = $args->{login_pw};
    my $base     = $args->{group} ? "http://$args->{group}.g.hatena.ne.jp/" : 'http://d.hatena.ne.jp/';

    my $self = bless {
        base     => $base,
        mech     => WWW::Mechanize->new,
        username => $login_id
    }, $class;

    croak 'Login failed'
        if !$self->login($login_id, $login_pw) || !($self->{rkm} = $self->get_rkm);

    $self;
}

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

    my $link;
    $self->{mech}->get('https://www.hatena.ne.jp/login');
    ($link) = map { $_->url } $self->{mech}->find_link( tag => 'meta' );

    unless ($link) {
        $self->{mech}->submit_form(
            fields => +{
                name     => $login_id,
                password => $login_pw,
            }
        );

        ($link) = map { $_->url } $self->{mech}->find_link( tag => 'meta' );
    }

    !!$link;
}

sub get_rkm {
    my $self = shift;
    $self->{mech}->get("$self->{base}$self->{username}/?mode=json");
    Load($self->{mech}->content)->{rkm};
}

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

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

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

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

    croak "Request failed: $self->{mech}->status"
        if !$self->{mech}->success;

    my $entry = Load($self->{mech}->content);
    if($args->{format}) {
        $entry->{body} = Text::Hatena->parse($entry->{body});
    }
    $entry;
}

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

        my $uri = "$self->{base}$self->{username}/edit?date=$y$m$d";
        $self->{mech}->get($uri);
        my $form = $self->{mech}->form_name('edit');
        my $body = $form->value('body');
        $args->{format} ? Text::Hatena->parse($body) : $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) = @_;

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

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

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

# TODO: implement delete method.
sub delete {
    my ($self, $args) = @_;

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

    die "Not implemented yet";
}

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

    if ($args->{date} =~ /^(\d{4})-(\d{2})-(\d{2})$/) {
        my ($y, $m, $d) = ($1, $2, $3);
        my $uri = "$self->{base}$self->{username}/edit?date=$y$m$d";
        $self->{mech}->get($uri);
        $self->{mech}->submit_form(form_number => 2);
    } else {
        carp "Invalid ymd format: $args->{date}. YYYY-MM-DD formatted date is required.";
    }

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

sub _post_entry {
    my ($self, $args) = @_;
    my $uri = $args->{uri} || "$self->{base}$self->{username}/";

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

    croak "Request failed: $self->{mech}->status"
        if !$self->{mech}->success;

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

1;

__END__

=for stopwords aaaatttt dotottto gmail

=head1 NAME

WWW::HatenaDiary - CRUD interface to Hatena::Diary

=head1 SYNOPSIS

  use WWW::HatenaDiary;

  my $diary = WWW::HatenaDiary->new({
      login_id => $login_id,
      login_pw => $login_pw,
  });

  # Create
  my $edit_uri = $diary->create({
      title => $title,
      body  => $body,
  });

  # Retrieve
  my $post = $diary->retrieve({
      uri => $edit_uri,
  })

  my $day_body = $diary->retrieve_day({
      date => $date,     # $date must be YYYY-MM-DD formatted string
  });

  # Update
  $edit_uri = $diary->update({
      uri   => $edit_uri,
      title => $new_title,
      body  => $new_body,
  });

  $diary->update_day({
      date => $date,     # $date must be YYYY-MM-DD formatted string
      body => $new_body,
  });

  # Delete
  $diary->delete({       # not implemented yet
      uri => $edit_uri,
  });

  $diary->delete_day({,
      date => $date,     # $date must be YYYY-MM-DD formatted string
  });

=head1 DESCRIPTION

WWW::HatenaDiary provides a CRUD interface to Hatena::Diary, aiming to
help you efficiently communicate with the service with programmatic
ways.

This module is, so far, for those who want to write some tools not
only to retrieve data from diaries, but also to create/update/delete
the posts at the same time. Which is why I adopted the way as if this
module treats such API like AtomPP, and this module retrieves and
returns raw formatted post content not a data already converted to
HTML.

=head1 METHODS

=head2 new ( I<\%args> )

=over 4

  my $diary = WWW::HatenaDiary->new({
      login_id => $login_id,
      login_pw => $login_pw,
  });

Creates and returns a new WWW::HatenaDiary object. Both C<login_id>
and C<login_pw> are required.

=back

=head2 create ( I<\%args> )

=over 4

  my $edit_uri = $diary->create({
      title => $title,
      body  => $body,
  });

Creates a new post and returns a URI as a L<URI> object for you to
retrieve/update/delete the post later on.

=back

=head2 retrieve ( I<\%args> )

=over 4

  my $post = $diary->retrieve({
      uri => $edit_uri,
  })

Retrieves the post for C<uri>. The return value C<$post> is a
reference to a hash which contains the fields as follows:

=over 4

=item * title

Title of the post.

=item * body

Content of the post as a raw formatted data.

=item * editable

Flag if you're authorized to edit the post or not.

=item * rkm

Token which is internally used when this module sends a request. You
needn't care about it.

=back

=back

=head2 retrieve_day ( I<\%args> )

=over 4

  my $day_body = $diary->retrieve_day({
      date => $date, # $date must be YYYY-MM-DD formatted string
  });

Retrieves the post body for C<date>. So far, this method gets only the
raw formatted content of the post.

=back

=head2 update ( I<\%args> )

=over 4

  $edit_uri = $diary->update({
      uri   => $edit_uri,
      title => $new_title,
      body  => $new_body,
  });

Updates the post for C<uri> and returns the URI as a L<URI> object for
you to do with the post still more.

=back

=head2 update_day ( I<\%args> )

=over 4

  $diary->update_day({
      date => $date,     # $date must be YYYY-MM-DD formatted string
      body => $new_body,
  });

Updates the whole posts of the C<date>. C<body> must be a
Hatena::Diary style formatted data, that is, this method emulates the
way when you write a post on your browser and send it via the form.

=back

=head2 delete ( I<\%args> ) **NOT IMPLEMENTED YET**

=over 4

  $diary->delete({
      uri => $edit_uri,
  });

Deletes the post for C<uri>.

=back

=head2 delete_day ( I<\%args> )

=over 4

  $diary->delete_day({
      date => $date, # $date must be YYYY-MM-DD formatted string
  });

Deletes the whole posts of the C<date>.

=back

=head1 SEE ALSO

=over 4

=item * Hatena::Diary (Japanese)

L<http://d.hatena.ne.jp/>

=back

=head1 ACKNOWLEDGMENT

typester++ for some codes copied from Fuse::Hatena.

=head1 AUTHOR

Tokuhiro Matsuno E<lt>tokuhirom aaaatttt gmail dotottto commmmmE<gt>

Kentaro Kuribayashi E<lt>kentarok aaaatttt gmail dotottto commmmmE<gt>

=head1 LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut