File Coverage

blib/lib/Hatena/Keyword.pm

Criterion	Covered	Total	%
statement	19	21	90.4
branch			n/a
condition			n/a
subroutine	7	7	100.0
pod			n/a
total	26	28	92.8

package Hatena::Keyword;
use strict;
use warnings;
use base qw(Class::Data::Inheritable Class::Accessor::Fast Class::ErrorHandler);
use overload '""' => \&as_string, fallback => 1;
use Carp;
use URI;
use RPC::XML;
use RPC::XML::Client;

our $VERSION = 0.05;

my @Fields = qw(refcount word score cname);
__PACKAGE__->mk_accessors(@Fields);
__PACKAGE__->mk_classdata(rpc_client => RPC::XML::Client->new(
    URI->new_abs('/xmlrpc', 'http://d.hatena.ne.jp/'),
    useragent => [ agent => join('/', __PACKAGE__, __PACKAGE__->VERSION) ],
));

sub extract {
    my $class = shift;
    my $body = shift or croak sprintf 'usage %s->extract($text)', $class;
    my $args = shift || {};
    $args->{mode} = 'lite';
    my $res = $class->_call_rpc_with_cache($body, $args)
        or $class->error($class->errstr);
    my @keywords = map { $class->_instance_from_rpcdata($_) }@{$res->{wordlist}};
    return wantarray ? @keywords : \@keywords;
}

sub markup_as_html {
    my $class = shift;
    my $body = shift or croak sprintf 'usage %s->markup_as_html($text)', $class;
    my $args = shift || {};
    $args->{mode} = '';
    my $res = $class->_call_rpc_with_cache($body, $args)
        or $class->error($class->errstr);
    return $res->value;
}

sub _call_rpc_with_cache {
    my $class = shift;
    my ($body, $args) = @_;
    $body = pack('C0A*', $body); # hacking for utf-8 flag
    my $cache = delete $args->{cache};
    return $class->_call_rpc($body, $args) unless ref($cache);
    croak "cache object must have get and set method."
        if not $cache->can('get') or not $cache->can('set');

    require Digest::MD5;
    require Storable;
    my $key = sprintf(
        '%s-%s-%s',
        $args->{mode} || '',
        Digest::MD5::md5_hex($body),
        Digest::MD5::md5_hex(Storable::freeze($args)),
    );
    my $res = Storable::thaw($cache->get($key));
    unless (defined $res) {
        $res = $class->_call_rpc($body, $args)
            or return $class->error($class->errstr);
        $cache->set($key =>Storable::freeze($res));
    }
    $res;
}

sub _call_rpc {
    my ($class, $body, $args) = @_;
    my $params = {
        body  => RPC::XML::string->new($body),
        score => RPC::XML::int->new($args->{score} || 0),
        mode  => RPC::XML::string->new($args->{mode} || ''),
        cname => defined $args->{cname} ? RPC::XML::array->new(
            map { RPC::XML::string->new($_) } @{$args->{cname}}
        ) : undef,
        a_target => RPC::XML::string->new($args->{a_target} || ''),
        a_class  => RPC::XML::string->new($args->{a_class} || ''),
    };

    # For all categories, It doesn't need an undefined cname value.
    delete $params->{cname} unless defined $params->{cname};

    my $res = $class->rpc_client->send_request(
        RPC::XML::request->new('hatena.setkeywordlink', $params),
    );
    return ref $res ? $res : $class->error(qq/RPC Error: "$res"/);
}

sub _instance_from_rpcdata {
    my ($class, $data) = @_;
    return $class->new({
        map {$_ => $data->{$_}->value  } @Fields,
    });
}

sub jcode {
    my $self = shift;
    $self->{_jcode} and return $self->{_jcode};
    require Jcode;
    return $self->{_jcode} = Jcode->new($self->as_string, 'utf8');
}

sub as_string { $_[0]->word }

1;

__END__