Yet Another Perl Module for Tumblr - 口から出まかせ

追記 2007/12/11

Tumblr v3 になってからメンテナンスしていないので現在このコードは動きません。

Tumblrのbotでも作ってみようかと思ったんだけど、APIからはReblogとかできないのでmechを使って書いてみた。モジュール書いたの初めて。名前がTumblr::BotとかだったりPODの英語がひどいってレベルじゃない、というか途中で書くのあきらめたりしてるけどそこは目をつぶってください。

参考にさせていただきました。ありがとうございます！

使う人がいるかどうかわかりませんが、ログインを伴う操作をするとブラウザの方がログアウトしてしまうので注意。readとwrite以外。

use Tumblr::Bot;
use YAML;
use XML::Simple;

my $email    = 'youremail@example.com';
my $password = 'password';

my $tumblr = Tumblr::Bot->new(
    email    => $email,
    password => $password,
);

warn $tumblr->dashboard;
warn Dump $tumblr->friends;
warn Dump $tumblr->followers;
warn Dump XMLin $tumblr->read(
    id    => 'user',
    start => 0,
    num   => 5,
);

$tumblr->write(
    type   => 'photo',
    source => 'http://example.com/photo.jpg',
);
$tumblr->add_friend('http://user.tumblr.com/');
$tumblr->reblog('http://user.tumblr.com/post/xxxxxxx');

package Tumblr::Bot;

use strict;
use WWW::Mechanize;
use WWW::Mechanize::DecodedContent;
use Web::Scraper;
use Switch;
use Encode qw//;
use URI;
our $VERSION = '0.01';

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

    my $email    = delete $options{email};
    my $password = delete $options{password};

    $options{agent}      ||= __PACKAGE__ . '/' . $Tumblr::Bot::VERSION;
    $options{cookie_jar} ||= {};

    my $mech = WWW::Mechanize->new(%options);
    my $self = bless {
        mech  => $mech,
        login => {
            email    => $email,
            password => $password,
        }
    }, $class;

    $self;
}

sub login {
    my $self = shift;

    $self->post( 'http://www.tumblr.com/login' => $self->{login} );

    warn 'logged in to tumblr';
}

sub get_content {
    my ( $self, $uri, $encoding ) = @_;

    my $content = $self->get($uri) ? $self->content : undef;

    if ( $content && $encoding ) {
        $content = Encode::encode( $encoding => $content );
    }
    $content;
}

sub get {
    my ( $self, $uri ) = @_;

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

    if ( $self->{mech}->uri =~ /login/ig ) {
        $self->login;
        $self->{mech}->get($uri);
    }

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

sub post {
    my ( $self, $uri, $options ) = @_;

    $self->{mech}->post($uri, $options);
    $self->{mech}->success;
}

sub content {
    my $self = shift;

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

sub dashboard {
    my $self = shift;

    $self->get_content('http://www.tumblr.com/dashboard');
}

sub read {
    my ( $self, %options ) = @_;

    my $id = delete $options{id};

    my $uri = URI->new( sprintf 'http://%s.tumblr.com/api/read', $id );
    $uri->query_form(\%options);

    $self->get_content($uri);
}

sub write {
    my ( $self, %params ) = @_;

    return unless $self->_validate_write(%params);

    $params{email}     = $self->{login}{email};
    $params{password}  = $self->{login}{password};
    $params{generator} = $self->{mech}{agent};

    $self->post( 'http://www.tumblr.com/api/write' => \%params );
}

sub _validate_write {
    my ( $self, %params ) = @_;

    switch ( lc $params{type} ) {
        case 'regular' {
            return (defined $params{title} || defined $params{body});
        }
        case 'photo' {
            return (defined $params{source} || defined $params{data});
        }
        case 'quote' {
            return defined $params{quote};
        }
        case 'link' {
            return defined $params{url};
        }
        case 'conversation' {
            return defined $params{conversation};
        }
        case 'video' {
            return defined $params{embed};
        }
    }
}

sub add_friend {
    my ( $self, $tumblr ) = @_;

    my $uri = URI->new('http://www.tumblr.com/publisher/iframe');
    $uri->query_form( src => $tumblr );

    $self->get($uri);

    if ( $self->content =~ /form/ ) {
        $self->{mech}->submit_form( form_number => 1 );
    }
    else {
        warn 'already your friend';
    }
}

sub friends {
    my $self = shift;

    my $scraper = scraper {
        process '//ul[@id="friends"]/li', 'friends[]' => scraper {
            process '//a[2]', name => 'TEXT',
            process '//a[2]', url  => '@href',
            process 'img',    img  => '@src',
        };
    };

    $scraper->scrape(
        \$self->dashboard, URI->new('http://www.tumblr.com/dashboard')
    )->{friends};
}

sub followers {
    my $self = shift;

    my $scraper = scraper {
        process '//ul[@id="followers"]/li/a[1]', 'followers[]' => scraper {
            process 'img', 'name' => '@alt',
            process 'a',    url   => '@href',
            process 'img', 'img'  => '@src',
        };
    };

    $scraper->scrape(
        \$self->dashboard, URI->new('http://www.tumblr.com/dashboard')
    )->{followers};
}

sub reblog {
    my ( $self, $post ) = @_;

    my($id) = $post =~ m{/post/(\d+)$};
    my $url = 'http://www.tumblr.com/reblog/' . $id;

    $self->get($url);
    $self->{mech}->submit_form( form_number => 1 );
}

1;
__END__

=head1 NAME

Tumblr::Bot

=head1 SYNOPSIS

  use Tumblr::Bot;
  use YAML;
  use XML::Simple;

  my $email    = 'youremail@example.com';
  my $password = 'password';

  my $tumblr = Tumblr::Bot->new(
      email    => $email,
      password => $password,
  );

  warn $tumblr->dashboard;
  warn Dump $tumblr->friends;
  warn Dump $tumblr->followers;
  warn Dump XMLin $tumblr->read(
      id    => 'user',
      start => 0,
      num   => 5,
  );

  $tumblr->write(
      type   => 'photo',
      source => 'http://example.com/photo.jpg',
  );
  $tumblr->add_friend('http://user.tumblr.com/');
  $tumblr->reblog('http://user.tumblr.com/post/xxxxxxx');

=head1 DESCRIPTION

Tumblr::Bot

=head1 METHODS

=head2 new

creates an object. You can pass the optional hash. Important keys are:

=over 4

=item email, passowrd

to log in to Tumblr.

=back

Other options woule be passed to Mech, too.

=head2 dashboard

return dashboard html string.

=head2 friends

return friends array ref contains name, url, avatar url.

=head2 followers

return followers array ref contains name, url, avatar url.

=head2 read

using read api. options are:

=over 4

=item id, start, num

see L<http://www.tumblr.com/api>

=back

=head2 write

using write api. options are:

=over 4

=item type

regular photo quote link conversation video

L<http://www.tumblr.com/api>

=back

=head2 add_friend

add friend.

=over 4

=item tumblr home url

=back

=head2 reblog

reblog post.

=over 4

=item permalink

=back

=head1 AUTHOR

Wataru Toya E<lt>watrty at gmail.comE<gt>

=head1 LICENSE

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

=head1 SEE ALSO

L<http://www.tumblr.com/>, L<http://www.tumblr.com/faqs>, L<http://www.tumblr.com/api>

=cut