root/lang/perl/WebService-Nowa/trunk/lib/WebService/Nowa.pm @ 5295

package WebService::Nowa;

# copyed from http://blog.livedoor.jp/nipotan/archives/50716810.html
use strict;
use 5.8.1;
our $VERSION = '0.01';

use strict;
use WWW::Mechanize;
use Time::HiRes qw(time);
use Carp;
use URI;
use JSON::Syck;
use Data::Dumper;
use Encode ();
use Scalar::Util qw(blessed);
use List::Util qw(first);
use Web::Scraper;

use constant NOWA_HOME => 'http://my.nowa.jp/home/';

sub new {
    my $class = shift;
    unless (ref($_[0]) eq 'HASH') {
        croak "invalid argument";
    }
    my $self = shift;
    my $mech = WWW::Mechanize->new( stack_depth => 1 );
    $mech->agent_alias('Windows IE 6');
    $self->{mech} = $mech;
    bless $self, $class;
    return $self;
}

sub update_nanishiteru {
    my($self, $nanishiteru) = @_;
    $self->_login unless $self->{_logged_in};
    $self->_home;
    my($rkey) =
        $self->{mech}->content =~ m{hitokoto\.init\(\s*"([a-z\d]+)"\s*\)}i;
    croak "Cannot find rkey" unless $rkey;
    my $uri = URI->new_abs('/internal_api/status_message/', NOWA_HOME);
    my($sec, $fsec) = time() =~ /^(\d+)(?:\.(\d+))?$/;
    $fsec = substr($fsec, 0, 3);
    $fsec .= '0' while length $fsec < 3;
    my $uniqid = sprintf('%d%d', $sec, $fsec);
    $uri->query_form(
        rkey   => $rkey,
        uniqid => $uniqid,
        body   => $nanishiteru,
    );
    $self->{mech}->get($uri->as_string);
    my $result = JSON::Syck::Load($self->{mech}->content);
    croak "Cannot update your nanishiteru." if $result->{status} ne 'success';
    return 1;
}

# from Web::Scraper
sub scrape {
    my ($self, $s, $url) = @_;

    my $stuff = $url;
    $stuff = $url->as_string if (blessed($url) && $url->isa('URI'));

    require Encode;
    require HTTP::Response::Encoding;

    my $res = $self->{mech}->get($stuff);
    my @encoding = (
        $res->encoding,
        ($res->header('Content-Type') =~ /charset=([\w\-]+)/g),
        "latin-1",
    );
    my $encoding = first { defined $_ && Encode::find_encoding($_) } @encoding;
    my $html = Encode::decode($encoding, $self->{mech}->content);

    my $base = ($res->content =~ /<base\s+href="([^"]+)"/)[0] || $stuff;

    my $scraped = $s->scrape($html, $base);
    $scraped;
}

sub channels {
    my $self = shift;
    $self->_login unless $self->{_logged_in};

    my $s = scraper {
        process 'ul.home-chlist > li', 'channels[]' => scraper {
            process 'a',
                'name', 'TEXT',
                'link', '@href';
        };
    };
    my $res = $self->scrape($s, URI->new('http://my.nowa.jp/home/'));
    my $data;
    for my $chan (@{ $res->{channels} }) {
        my $id = '#' . ($chan->{link} =~ m!^http://nowa.jp/ch/(.*?)/!)[0];
        my $name = $chan->{name};
        $name =~ s/\(\d+\)$//;
        $data->{$id} = $name;
    }
    return wantarray ? %$data : $data;
}

sub recent {
    my $self = shift;
    $self->_login unless $self->{_logged_in};

    my $s = scraper {
        process '//div[@class="friendentry-box clearfix"]', 'entries[]' => scraper {
            process '//div[@class="friendentrybody"]/a', 'userlink', '@href';
            process 'span.time > a', 'permalink', '@href';

            # message
            process 'h2.statustitle', 'body', 'TEXT';

            # entry
            process '//h2[@class!="statustitle"]/a',
                'entry', 'TEXT',
                'entrylink', '@href';
        };
    };
    my $res = $self->scrape($s, URI->new('http://my.nowa.jp/friend/'));

    my @data;
    for my $entry (@{ $res->{entries} }) {
        my $user = ($entry->{userlink} =~ m!^http://([^\.]+)\.nowa\.jp/!)[0];
        my $body;
        if ($entry->{entry}) {
            $body = $entry->{entry} . " " . $entry->{entrylink};
            $entry->{permalink} = $entry->{entrylink};
        } else {
            $body = $entry->{body};
        }

        push(@data, +{
            user      => $user,
            permalink => $entry->{permalink},
            body      => $body,
        });
    }

    return wantarray ? @data : \@data;
}

sub _home {
    my $self = shift;
    if ($self->{mech}->uri ne NOWA_HOME) {
        $self->{mech}->get(NOWA_HOME);
    }
    $self->_login unless $self->{mech}->uri ne NOWA_HOME;
}

sub _login {
    my $self = shift;
    $self->{mech}->get(NOWA_HOME);
    $self->{_logged_in} = 1 if $self->{mech}->uri eq NOWA_HOME;
    return if $self->{_logged_in};
    my $uri = $self->{mech}->uri;
    $self->{mech}->submit_form(
        form_number => 1,
        fields      => +{
            nowa_id  => $self->{nowa_id},
            password => $self->{password},
        },
    );
    croak("login failed.") if $self->{mech}->uri eq $uri;
    $self->{_logged_in} = 1;
}

1;

__END__

=head1 NAME

WebService::Nowa -

=head1 SYNOPSIS

  use WebService::Nowa;

=head1 DESCRIPTION

WebService::Nowa is

=head1 AUTHOR

woremacx E<lt>woremacx at gmail dot 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

=cut